dslinux/user/perl/win32 FindExt.pm Makefile buildext.pl config.bc config.gc config.vc config.vc64 config_H.bc config_H.gc config_H.vc config_H.vc64 config_h.PL config_sh.PL distclean.bat dl_win32.xs fcrypt.c genmk95.pl makefile.mk makeico.pl mdelete.bat perlexe.rc perlglob.c perlhost.h perllib.c pod.mak runperl.c splittree.pl sync_ext.pl vdir.h vmem.h win32.c win32.h win32io.c win32iop.h win32sck.c win32thread.c win32thread.h
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:02:24 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/win32
In directory antilope:/tmp/cvs-serv17422/win32
Added Files:
FindExt.pm Makefile buildext.pl config.bc config.gc config.vc
config.vc64 config_H.bc config_H.gc config_H.vc config_H.vc64
config_h.PL config_sh.PL distclean.bat dl_win32.xs fcrypt.c
genmk95.pl makefile.mk makeico.pl mdelete.bat perlexe.rc
perlglob.c perlhost.h perllib.c pod.mak runperl.c splittree.pl
sync_ext.pl vdir.h vmem.h win32.c win32.h win32io.c win32iop.h
win32sck.c win32thread.c win32thread.h
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: dl_win32.xs ---
/* dl_win32.xs
*
* Platform: Win32 (Windows NT/Windows 95)
* Author: Wei-Yuen Tan (wyt at hip.com)
* Created: A warm day in June, 1995
*
* Modified:
* August 23rd 1995 - rewritten after losing everything when I
* wiped off my NT partition (eek!)
*/
/* Porting notes:
I merely took Paul's dl_dlopen.xs, took out extraneous stuff and
replaced the appropriate SunOS calls with the corresponding Win32
calls.
*/
#define WIN32_LEAN_AND_MEAN
#ifdef __GNUC__
#define Win32_Winsock
#endif
#include <windows.h>
#include <string.h>
#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "win32.h"
#include "XSUB.h"
typedef struct {
SV * x_error_sv;
} my_cxtx_t; /* this *must* be named my_cxtx_t */
#define DL_CXT_EXTRA /* ask for dl_cxtx to be defined in dlutils.c */
#include "dlutils.c" /* SaveError() etc */
#define dl_error_sv (dl_cxtx.x_error_sv)
static char *
OS_Error_String(pTHX)
{
dMY_CXT;
DWORD err = GetLastError();
STRLEN len;
if (!dl_error_sv)
dl_error_sv = newSVpvn("",0);
PerlProc_GetOSError(dl_error_sv,err);
return SvPV(dl_error_sv,len);
}
static void
dl_private_init(pTHX)
{
(void)dl_generic_private_init(aTHX);
}
/*
This function assumes the list staticlinkmodules
will be formed from package names with '::' replaced
with '/'. Thus Win32::OLE is in the list as Win32/OLE
*/
static int
dl_static_linked(char *filename)
{
char **p;
char *ptr, *hptr;
static char subStr[] = "/auto/";
char szBuffer[MAX_PATH];
/* change all the '\\' to '/' */
strcpy(szBuffer, filename);
for(ptr = szBuffer; ptr = strchr(ptr, '\\'); ++ptr)
*ptr = '/';
/* delete the file name */
ptr = strrchr(szBuffer, '/');
if(ptr != NULL)
*ptr = '\0';
/* remove leading lib path */
ptr = strstr(szBuffer, subStr);
if(ptr != NULL)
ptr += sizeof(subStr)-1;
else
ptr = szBuffer;
for (p = staticlinkmodules; *p;p++) {
if (hptr = strstr(ptr, *p)) {
/* found substring, need more detailed check if module name match */
if (hptr==ptr) {
return strcmp(ptr, *p)==0;
}
if (hptr[strlen(*p)] == 0)
return hptr[-1]=='/';
}
};
return 0;
}
MODULE = DynaLoader PACKAGE = DynaLoader
BOOT:
(void)dl_private_init(aTHX);
void *
dl_load_file(filename,flags=0)
char * filename
int flags
PREINIT:
CODE:
{
DLDEBUG(1,PerlIO_printf(Perl_debug_log,"dl_load_file(%s):\n", filename));
if (dl_static_linked(filename) == 0) {
RETVAL = PerlProc_DynaLoad(filename);
}
else
RETVAL = (void*) GetModuleHandle(NULL);
DLDEBUG(2,PerlIO_printf(Perl_debug_log," libref=%x\n", RETVAL));
ST(0) = sv_newmortal() ;
if (RETVAL == NULL)
SaveError(aTHX_ "load_file:%s",
OS_Error_String(aTHX)) ;
else
sv_setiv( ST(0), (IV)RETVAL);
}
int
dl_unload_file(libref)
void * libref
CODE:
DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_unload_file(%lx):\n", PTR2ul(libref)));
RETVAL = FreeLibrary(libref);
if (!RETVAL)
SaveError(aTHX_ "unload_file:%s", OS_Error_String(aTHX)) ;
DLDEBUG(2,PerlIO_printf(Perl_debug_log, " retval = %d\n", RETVAL));
OUTPUT:
RETVAL
void *
dl_find_symbol(libhandle, symbolname)
void * libhandle
char * symbolname
CODE:
DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_find_symbol(handle=%x, symbol=%s)\n",
libhandle, symbolname));
RETVAL = (void*) GetProcAddress((HINSTANCE) libhandle, symbolname);
DLDEBUG(2,PerlIO_printf(Perl_debug_log," symbolref = %x\n", RETVAL));
ST(0) = sv_newmortal() ;
if (RETVAL == NULL)
SaveError(aTHX_ "find_symbol:%s",
OS_Error_String(aTHX)) ;
else
sv_setiv( ST(0), (IV)RETVAL);
void
dl_undef_symbols()
PPCODE:
# These functions should not need changing on any platform:
void
dl_install_xsub(perl_name, symref, filename="$Package")
char * perl_name
void * symref
char * filename
CODE:
DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_install_xsub(name=%s, symref=%x)\n",
perl_name, symref));
ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
(void(*)(pTHX_ CV *))symref,
filename)));
char *
dl_error()
CODE:
dMY_CXT;
RETVAL = dl_last_error;
OUTPUT:
RETVAL
# end.
--- NEW FILE: fcrypt.c ---
/* fcrypt.c */
/* Copyright (C) 1993 Eric Young - see README for more details */
#include <stdio.h>
/* 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 at psych.psy.uq.oz.au
*/
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 at lccmail.ocf.llnl.gov)
* for the inspiration. :-) */
PERM_OP (d,c,t,4,0x0f0f0f0f);
HPERM_OP(c,t,-2,0xcccc0000);
HPERM_OP(d,t,-2,0xcccc0000);
PERM_OP (d,c,t,1,0x55555555);
PERM_OP (c,d,t,8,0x00ff00ff);
PERM_OP (d,c,t,1,0x55555555);
d= (((d&0x000000ff)<<16)| (d&0x0000ff00) |
((d&0x00ff0000)>>16)|((c&0xf0000000)>>4));
c&=0x0fffffff;
for (i=0; i<ITERATIONS; i++)
{
if (shifts2[i])
{ c=((c>>2)|(c<<26)); d=((d>>2)|(d<<26)); }
else
{ c=((c>>1)|(c<<27)); d=((d>>1)|(d<<27)); }
c&=0x0fffffff;
d&=0x0fffffff;
/* could be a few less shifts but I am to lazy at this
* point in time to investigate */
s= skb[0][ (c )&0x3f ]|
skb[1][((c>> 6)&0x03)|((c>> 7)&0x3c)]|
skb[2][((c>>13)&0x0f)|((c>>14)&0x30)]|
skb[3][((c>>20)&0x01)|((c>>21)&0x06) |
((c>>22)&0x38)];
t= skb[4][ (d )&0x3f ]|
skb[5][((d>> 7)&0x03)|((d>> 8)&0x3c)]|
skb[6][ (d>>15)&0x3f ]|
skb[7][((d>>21)&0x0f)|((d>>22)&0x30)];
/* table contained 0213 4657 */
*(k++)=((t<<16)|(s&0x0000ffff))&0xffffffff;
s= ((s>>16)|(t&0xffff0000));
s=(s<<4)|(s>>28);
*(k++)=s&0xffffffff;
}
return(0);
}
/******************************************************************
* modified stuff for crypt.
******************************************************************/
/* 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 <how at isl.stanford.edu>
* 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);
}
--- NEW FILE: config.vc ---
## Configured by: ~cf_email~
## Target system: WIN32
Author=''
Date='$Date'
Header=''
Id='$Id'
Locker=''
Log='$Log'
Mcc='Mcc'
RCSfile='$RCSfile'
Revision='$Revision'
Source=''
State=''
_a='.lib'
_exe='.exe'
_o='.obj'
afs='false'
afsroot='/afs'
alignbytes='8'
[...989 lines suppressed...]
vendorscript=''
vendorscriptexp=''
version='~VERSION~'
version_patchlevel_string=''
versiononly='undef'
vi=''
voidflags='15'
xlibpth='/usr/lib/386 /lib/386'
yacc='yacc'
yaccflags=''
zcat=''
zip='zip'
PERL_REVISION='~PERL_REVISION~'
PERL_SUBVERSION='~PERL_SUBVERSION~'
PERL_VERSION='~PERL_VERSION~'
PERL_API_REVISION='~PERL_API_REVISION~'
PERL_API_SUBVERSION='~PERL_API_SUBVERSION~'
PERL_API_VERSION='~PERL_API_VERSION~'
PERL_PATCHLEVEL='~PERL_VERSION~'
PERL_CONFIG_SH='true'
--- NEW FILE: Makefile ---
#
# Makefile to build perl on Windows NT using Microsoft NMAKE.
# Supported compilers:
# Visual C++ 2.0 through 7.0 (and possibly newer versions)
# MS Platform SDK 64-bit compiler and tools **experimental**
#
# This is set up to build a perl.exe that runs off a shared library
# (perl58.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.
##
#
[...1290 lines suppressed...]
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
--- NEW FILE: sync_ext.pl ---
=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();
--- NEW FILE: config_H.gc ---
/*
* 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.gc,v 1.2 2006-12-04 17:02:18 dslinux_cayenne Exp $
*/
/*
* Package name : perl5
* Source directory :
* Configuration time: Mon Mar 17 20:15:35 2003
* Configured by : gsar
* Target system :
*/
[...4336 lines suppressed...]
* 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
--- NEW FILE: config.gc ---
## Configured by: ~cf_email~
## Target system: WIN32
Author=''
Date='$Date'
Header=''
Id='$Id'
Locker=''
Log='$Log'
Mcc='Mcc'
RCSfile='$RCSfile'
Revision='$Revision'
Source=''
State=''
_a='.a'
_exe='.exe'
_o='.o'
afs='false'
afsroot='/afs'
alignbytes='8'
[...989 lines suppressed...]
vendorscript=''
vendorscriptexp=''
version='~VERSION~'
version_patchlevel_string=''
versiononly='undef'
vi=''
voidflags='15'
xlibpth='/usr/lib/386 /lib/386'
yacc='yacc'
yaccflags=''
zcat=''
zip='zip'
PERL_REVISION='~PERL_REVISION~'
PERL_SUBVERSION='~PERL_SUBVERSION~'
PERL_VERSION='~PERL_VERSION~'
PERL_API_REVISION='~PERL_API_REVISION~'
PERL_API_SUBVERSION='~PERL_API_SUBVERSION~'
PERL_API_VERSION='~PERL_API_VERSION~'
PERL_PATCHLEVEL='~PERL_VERSION~'
PERL_CONFIG_SH='true'
--- NEW FILE: mdelete.bat ---
@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
--- NEW FILE: makefile.mk ---
#
# Makefile to build perl on Windows NT using DMAKE.
# Supported compilers:
# Visual C++ 2.0 through 7.0 (and possibly newer versions)
# Borland C++ 5.02 or better
# Mingw32 with gcc-2.95.2 or better
# MS Platform SDK 64-bit compiler and tools **experimental**
#
# This is set up to build a perl.exe that runs off a shared library
# (perl58.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.
##
[...1471 lines suppressed...]
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
--- NEW FILE: perlglob.c ---
/*
* Globbing for NT. Relies on the expansion done by the library
* startup code.
*/
#include <stdio.h>
#include <io.h>
#include <fcntl.h>
#include <string.h>
#include <windows.h>
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;
}
--- NEW FILE: win32iop.h ---
#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 <sys/utime.h>
#else
# include <utime.h>
#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_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(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 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
/*
* 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())
#define strerror win32_strerror
/*
* 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 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 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
#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 */
--- NEW FILE: perllib.c ---
/*
* "The Road goes ever on and on, down from the door where it began."
*/
#define PERLIO_NOT_STDIO 0
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#ifdef PERL_IMPLICIT_SYS
#include "win32iop.h"
#include <fcntl.h>
#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
#include "perlhost.h"
void
win32_checkTLS(PerlInterpreter *host_perl)
{
dTHX;
if (host_perl != my_perl) {
int *nowhere = NULL;
*nowhere = 0;
abort();
}
}
EXTERN_C void
perl_get_host_info(struct IPerlMemInfo* perlMemInfo,
struct IPerlMemInfo* perlMemSharedInfo,
struct IPerlMemInfo* perlMemParseInfo,
struct IPerlEnvInfo* perlEnvInfo,
struct IPerlStdIOInfo* perlStdIOInfo,
struct IPerlLIOInfo* perlLIOInfo,
struct IPerlDirInfo* perlDirInfo,
struct IPerlSockInfo* perlSockInfo,
struct IPerlProcInfo* perlProcInfo)
{
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;
#ifndef __BORLANDC__
/* XXX this _may_ be a problem on some compilers (e.g. Borland) that
* want to free() argv after main() returns. As luck would have it,
* Borland's CRT does the right thing to argv[0] already. */
char szModuleName[MAX_PATH];
GetModuleFileName(NULL, szModuleName, sizeof(szModuleName));
(void)win32_longpath(szModuleName);
argv[0] = szModuleName;
#endif
#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;
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
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
DisableThreadLibraryCalls((HMODULE)hModule);
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_5005THREADS) || 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
--- NEW FILE: genmk95.pl ---
# 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";
--- NEW FILE: makeico.pl ---
binmode STDOUT;
while (<DATA>) {
chomp;
print pack "H*", $_;
}
# Create new hex data with
# perl -wle "binmode STDIN; $/ = \32; while (<>) {print unpack 'H*', $_}" <perl.ico.orig
# then place after __DATA__
__DATA__
0000010003001010100001000400280100003600000010100000010008006805
00005e010000101000000100200068040000c606000028000000100000002000
00000100040000000000c000000000000000000000000000000000000000ffff
ff007b000000007b00007b7b000000007b007b007b00007b7b00bdbdbd007b7b
7b00ff00000000ff0000ffff00000000ff00ff00ff0000ffff0000000000ffff
fffffffffffffffffffff7ff8fffffffffffff8fffffffffffffff7fffffffff
ffffff8fffffffffffffff8fffffffffffffff8f7ffffffffffffffff87fffff
fffffffffffffffff8fffffff8ffffffff8ffffffffffffffff8ffff7fffff8f
f8ff8ffffffffffffffff8ffffffffffffffffffffffffffffffffffffffffff
9e5cfbb77420fd9b7865fd9b2074fd5b7320fd5b6e20fd137573f0017072e003
6c65e0032077e4076e20e6076577c30f6720ff9f6520ffff6f6effff6e202800
0000100000002000000001000800000000004001000000000000000000000000
000000000000ffffff00fefefe00d6d6d600aaaaaa00fdfdfd00797979000000
00007a7a7a00fcfcfc004141410075757500848484001e1e1e00cbcbcb00b7b7
b70003030300888888000202020081818100f6f6f60020202000b6b6b6008a8a
8a00040404001a1a1a00e7e7e7000e0e0e00383838006b6b6b0018181800b2b2
b200c1c1c10015151600171717000b0b0b00010101001f1f1f000a0a0a007070
70009b9b9b00e9e9e80078787800111111002323230044444400e2e2e200a6a6
a600656565006a6a6a00b4b4b400afafaf00cfcfcf00080808006c6c6c008f8f
8f00b1b1b100bfbfbf00f1f1f100585858009a9a9a00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00060606060606060606060606060606060606060606060606060d
06063a060606060606060606060606061c060606060606060606060606060606
030606060606060606060606060606061c060606060606060606060606060606
1c060606060606060606060606060c14090605060606060606060c0c06060606
061406052706060606060606060606060606060c060606060606061b06060606
0606061c06060606060614060b06060606060c060606060606060606060b0606
06060b06060606060906060506060b06060c0606060606060606060606060605
0606060606060606060606060606060606060606060606060606060606060606
060606060606ffff9e5cfbb77420fd9b7865fd9b2074fd5b7320fd5b6e20fd13
7573f0017072e0036c65e0032077e4076e20e6076577c30f6720ff9f6520ffff
6f6effff6e202800000010000000200000000100200000000000400400000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000ff00000070000000010000004ebfbfbf400000000e000000005858
58a7000000650000000000000000000000000000000000000000000000000000
000000000030000000ff0000000100000001080808f76c6c6c93000000000000
0001000000ff0000000000000000000000000000000000000000000000000000
000000000003000000ff000000010000004b000000ffafafaf50000000000000
0001000000ff0000000100000000000000000000000000000000000000000000
000000000001000000ff00000001000000ff000000006a6a6a95000000010000
0001000000ff0000000100000000000000000000000000000000000000000000
000000000001000000ff00000001000000ff000000596565659a000000010000
0001000000ff0000000000000000000000000000000000000000000000000000
000000000017000000ff00000087111111ee232323dc444444bb000000017a7a
7a85000000ff0000001d000000000000000000000000000000010000003e1515
16ea171717e8020202fd0b0b0bf4010101fe000000ff020202fd1f1f1fe00a0a
0af57070708f9b9b9b6400000000000000000000000000000001000000ff0000
00ff000000ff000000ff000000ff000000ff000000ff000000ff000000ff0000
00ff181818e70000004d00000000000000000000000000000001000000ff0e0e
0ef1383838c7000000ff000000ff000000ff000000ff000000ff000000ff0000
00ff6b6b6b940000000000000000000000000000000000000000000000ff2020
20df000000498a8a8a75040404fb000000ff000000ff000000ff000000ff1a1a
1ae5000000180000000000000000000000000000000000000048000000ff0303
03fc0000008a0000000188888877020202fd000000ff000000ff000000ff8181
817e0000000900000000000000000000000000000000414141be000000ff0000
00ff7575758a00000000000000008484847b000000ff000000ff1e1e1ee10000
0034000000000000000000000000000000000000000000000001000000290000
00550000000100000000000000000000000279797986000000ff000000850000
0003000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000ffff9e5cfbb77420fd9b7865fd9b2074fd5b
7320fd5b6e20fd137573f0017072e0036c65e0032077e4076e20e6076577c30f
6720ff9f6520ffff6f6effff6e20
--- NEW FILE: config_H.bc ---
/*
* 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.bc,v 1.2 2006-12-04 17:02:18 dslinux_cayenne Exp $
*/
/*
* Package name : perl5
* Source directory :
* Configuration time: Mon Mar 17 20:15:35 2003
* Configured by : gsar
* Target system :
*/
[...4332 lines suppressed...]
* 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
--- NEW FILE: win32.c ---
/* WIN32.C
*
* (c) 1995 Microsoft Corporation. All rights reserved.
* Developed by hip communications inc., http://info.hip.com/info/
* 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 <tchar.h>
#ifdef __GNUC__
#define Win32_Winsock
#endif
#include <windows.h>
/* GCC-2.95.2/Mingw32-1.1 forgot the WINAPI on CommandLineToArgvW() */
#if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
[...5223 lines suppressed...]
}
void
win32_argv2utf8(int argc, char** argv)
{
dTHX;
char* psz;
int length, wargc;
LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
if (lpwStr && argc) {
while (argc--) {
length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
Newxz(psz, length, char);
WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
argv[argc] = psz;
}
call_atexit(win32_free_argvw, argv);
}
GlobalFree((HGLOBAL)lpwStr);
}
--- NEW FILE: win32.h ---
/* WIN32.H
*
* (c) 1995 Microsoft Corporation. All rights reserved.
* Developed by hip communications inc., http://info.hip.com/info/
*
* 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 <windows.h>
#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 <dirent.h>
#include <io.h>
#include <process.h>
#include <stdio.h>
#include <direct.h>
#include <stdlib.h>
#include <stddef.h>
#include <fcntl.h>
#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 */
#if (defined(_M_IX86) && _MSC_VER >= 1000) || 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. */
#ifdef __BORLANDC__ /* Borland C++ */
#if (__BORLANDC__ <= 0x520)
#define _access access
#define _chdir chdir
#endif
#define _getpid getpid
#define wcsicmp _wcsicmp
#include <sys/types.h>
#ifndef DllMain
#define DllMain DllEntryPoint
#endif
#pragma warn -ccc /* "condition is always true/false" */
#pragma warn -rch /* "unreachable code" */
#pragma warn -sig /* "conversion may lose significant digits" */
#pragma warn -pia /* "possibly incorrect assignment" */
#pragma warn -par /* "parameter 'foo' is never used" */
#pragma warn -aus /* "'foo' is assigned a value that is never used" */
#pragma warn -use /* "'foo' is declared but never used" */
#pragma warn -csu /* "comparing signed and unsigned values" */
/* 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++ */
typedef long uid_t;
typedef long gid_t;
typedef unsigned short mode_t;
#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
#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
#define isnan _isnan /* ...same libraries as MSVC */
#ifndef _O_NOINHERIT
# define _O_NOINHERIT 0x0080
# ifndef _NO_OLDNAMES
# define O_NOINHERIT _O_NOINHERIT
# endif
#endif
/* <stdint.h>, pulled in by <io.h> 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);
#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);
#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);
extern char * win32_get_sitelib(const char *pl);
extern char * win32_get_vendorlib(const char *pl);
extern int IsWin95(void);
extern int IsWinNT(void);
extern void win32_argv2utf8(int argc, char** argv);
#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 <sys/socket.h>
#include <netdb.h>
#ifdef MYMALLOC
#define EMBEDMYMALLOC /**/
/* #define USE_PERL_SBRK /**/
/* #define PERL_SBRK_VIA_MALLOC /**/
#endif
#if defined(PERLDLL) && !defined(PERL_CORE)
#define PERL_CORE
#endif
#ifdef PERL_TEXTMODE_SCRIPTS
# define PERL_SCRIPT_MODE "r"
#else
# define PERL_SCRIPT_MODE "rb"
#endif
/*
* Now Win32 specific per-thread data stuff
*/
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;
};
#ifdef USE_5005THREADS
# ifndef USE_DECLSPEC_THREAD
# define HAVE_THREAD_INTERN
# endif /* !USE_DECLSPEC_THREAD */
#endif /* USE_5005THREADS */
#define HAVE_INTERP_INTERN
typedef struct {
long num;
DWORD pids[MAXIMUM_WAIT_OBJECTS];
HANDLE handles[MAXIMUM_WAIT_OBJECTS];
} child_tab;
#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;
child_tab * pseudo_children;
#endif
void * internal_host;
#ifndef USE_5005THREADS
struct thread_intern thr_intern;
#endif
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_internal_host (PL_sys_intern.internal_host)
#define w32_timerid (PL_sys_intern.timerid)
#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)
#ifdef USE_5005THREADS
# define w32_strerror_buffer (thr->i.Wstrerror_buffer)
# define w32_getlogin_buffer (thr->i.Wgetlogin_buffer)
# define w32_crypt_buffer (thr->i.Wcrypt_buffer)
# define w32_servent (thr->i.Wservent)
# define w32_init_socktype (thr->i.Winit_socktype)
# define w32_use_showwindow (thr->i.Wuse_showwindow)
# define w32_showwindow (thr->i.Wshowwindow)
#else
# 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)
#endif /* USE_5005THREADS */
/* UNICODE<>ANSI translation helpers */
/* Use CP_ACP when mode is ANSI */
/* Use CP_UTF8 when mode is UTF8 */
#define A2WHELPER_LEN(lpa, alen, lpw, nBytes)\
(lpw[0] = 0, MultiByteToWideChar((IN_BYTES) ? CP_ACP : CP_UTF8, 0, \
lpa, alen, lpw, (nBytes/sizeof(WCHAR))))
#define A2WHELPER(lpa, lpw, nBytes) A2WHELPER_LEN(lpa, -1, lpw, nBytes)
#define W2AHELPER_LEN(lpw, wlen, lpa, nChars)\
(lpa[0] = '\0', WideCharToMultiByte((IN_BYTES) ? CP_ACP : CP_UTF8, 0, \
lpw, wlen, (LPSTR)lpa, nChars,NULL,NULL))
#define W2AHELPER(lpw, lpa, nChars) W2AHELPER_LEN(lpw, -1, lpa, nChars)
#define USING_WIDE() (0)
#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()
#endif /* _INC_WIN32_PERL5 */
--- NEW FILE: vmem.h ---
/* 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)
*
*/
[...1209 lines suppressed...]
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___ */
--- NEW FILE: config.vc64 ---
## Configured by: ~cf_email~
## Target system: WIN32
Author=''
Date='$Date'
Header=''
Id='$Id'
Locker=''
Log='$Log'
Mcc='Mcc'
RCSfile='$RCSfile'
Revision='$Revision'
Source=''
State=''
_a='.lib'
_exe='.exe'
_o='.obj'
afs='false'
afsroot='/afs'
alignbytes='8'
[...989 lines suppressed...]
vendorscript=''
vendorscriptexp=''
version='~VERSION~'
version_patchlevel_string=''
versiononly='undef'
vi=''
voidflags='15'
xlibpth='/usr/lib/386 /lib/386'
yacc='yacc'
yaccflags=''
zcat=''
zip='zip'
PERL_REVISION='~PERL_REVISION~'
PERL_SUBVERSION='~PERL_SUBVERSION~'
PERL_VERSION='~PERL_VERSION~'
PERL_API_REVISION='~PERL_API_REVISION~'
PERL_API_SUBVERSION='~PERL_API_SUBVERSION~'
PERL_API_VERSION='~PERL_API_VERSION~'
PERL_PATCHLEVEL='~PERL_VERSION~'
PERL_CONFIG_SH='true'
--- NEW FILE: buildext.pl ---
=head1 NAME
buildext.pl - build extensions
=head1 SYNOPSIS
buildext.pl make [-make_opts] dep directory [target] [--static|--dynamic] !ext1 !ext2
E.g.
buildext.pl nmake -nologo perldll.def ..\ext
buildext.pl nmake -nologo perldll.def ..\ext clean
buildext.pl dmake perldll.def ..\ext
buildext.pl dmake perldll.def ..\ext clean
Will skip building extensions which are marked with an '!' char.
Mostly because they still not ported to specified platform.
If '--static' specified, only static extensions will be built.
If '--dynamic' specified, only dynamic extensions will be built.
--create-perllibst-h
creates perllibst.h file for inclusion from perllib.c
--list-static-libs:
prints libraries for static linking and exits
=cut
use Cwd;
use FindExt;
use Config;
# @ARGV with '!' at first position are exclusions
my %excl = map {$_=>1} map {/^!(.*)$/} @ARGV;
@ARGV = grep {!/^!/} @ARGV;
# --static/--dynamic
my %opts = map {$_=>1} map {/^--([\w\-]+)$/} @ARGV;
@ARGV = grep {!/^--([\w\-]+)$/} @ARGV;
my ($static,$dynamic) = ((exists $opts{static}?1:0),(exists $opts{dynamic}?1:0));
if ("$static,$dynamic" eq "0,0") {
($static,$dynamic) = (1,1);
}
if ($opts{'list-static-libs'} || $opts{'create-perllibst-h'}) {
my @statics = split /\s+/, $Config{static_ext};
if ($opts{'create-perllibst-h'}) {
open my $fh, ">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";
}
else {
my %extralibs;
for (@statics) {
open my $fh, "<..\\lib\\auto\\$_\\extralibs.ld" or die "can't open <..\\lib\\auto\\$_\\extralibs.ld: $!";
$extralibs{$_}++ for grep {/\S/} split /\s+/, join '', <$fh>;
}
print map {s|/|\\|g;m|([^\\]+)$|;"..\\lib\\auto\\$_\\$1$Config{_a} "} @statics;
print map {"$_ "} sort keys %extralibs;
}
exit;
}
my $here = getcwd();
my $perl = $^X;
$here =~ s,/,\\,g;
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}";
#print "PATH=$ENV{PATH}\n";
my $pl2bat = "$topdir\\win32\\bin\\pl2bat";
unless (-f "$pl2bat.bat") {
my @args = ($perl, ("$pl2bat.pl") x 2);
print "@args\n";
system(@args) unless defined $::Cross::platform;
}
my $make = shift;
$make .= " ".shift while $ARGV[0]=~/^-/;
my $dep = shift;
my $dmod = -M $dep;
my $dir = shift;
chdir($dir) || die "Cannot cd to $dir\n";
my $targ = shift;
(my $ext = getcwd()) =~ s,/,\\,g;
my $code;
FindExt::scan_ext($ext);
FindExt::set_static_extensions(split ' ', $Config{static_ext}) if $ext ne "ext";
my @ext;
push @ext, FindExt::static_ext() if $static;
push @ext, FindExt::dynamic_ext(), FindExt::nonxs_ext() if $dynamic;
foreach $dir (sort @ext)
{
if (exists $excl{$dir}) {
warn "Skipping extension $ext\\$dir, not ported to current platform";
next;
}
if (chdir("$ext\\$dir"))
{
my $mmod = -M 'Makefile';
if (!(-f 'Makefile') || $mmod > $dmod)
{
print "\nRunning Makefile.PL in $dir\n";
my @perl = ($perl, "-I$here\\..\\lib", 'Makefile.PL',
'INSTALLDIRS=perl', 'PERL_CORE=1',
(FindExt::is_static($dir)
? ('LINKTYPE=static') : ()), # if ext is static
);
if (defined $::Cross::platform) {
@perl = (@perl[0,1],"-MCross=$::Cross::platform", at perl[2..$#perl]);
}
print join(' ', @perl), "\n";
$code = system(@perl);
warn "$code from $dir\'s Makefile.PL" if $code;
$mmod = -M 'Makefile';
if ($mmod > $dmod)
{
warn "Makefile $mmod > $dmod ($dep)\n";
}
}
if ($targ)
{
print "Making $targ in $dir\n$make $targ\n";
$code = system("$make $targ");
die "Unsuccessful make($dir): code=$code" if $code!=0;
}
else
{
print "Making $dir\n$make\n";
$code = system($make);
die "Unsuccessful make($dir): code=$code" if $code!=0;
}
chdir($here) || die "Cannot cd to $here:$!";
}
else
{
warn "Cannot cd to $ext\\$dir:$!";
}
}
--- NEW FILE: config_H.vc ---
/*
* 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.vc,v 1.2 2006-12-04 17:02:18 dslinux_cayenne Exp $
*/
/*
* Package name : perl5
* Source directory :
* Configuration time: Wed Mar 19 16:24:01 2003
* Configured by : gsar
* Target system :
*/
[...4332 lines suppressed...]
* 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
--- NEW FILE: config.bc ---
## Configured by: ~cf_email~
## Target system: WIN32
Author=''
Date='$Date'
Header=''
Id='$Id'
Locker=''
Log='$Log'
Mcc='Mcc'
RCSfile='$RCSfile'
Revision='$Revision'
Source=''
State=''
_a='.lib'
_exe='.exe'
_o='.obj'
afs='false'
afsroot='/afs'
alignbytes='8'
[...989 lines suppressed...]
vendorscript=''
vendorscriptexp=''
version='~VERSION~'
version_patchlevel_string=''
versiononly='undef'
vi=''
voidflags='15'
xlibpth='/usr/lib/386 /lib/386'
yacc='yacc'
yaccflags=''
zcat=''
zip='zip'
PERL_REVISION='~PERL_REVISION~'
PERL_SUBVERSION='~PERL_SUBVERSION~'
PERL_VERSION='~PERL_VERSION~'
PERL_API_REVISION='~PERL_API_REVISION~'
PERL_API_SUBVERSION='~PERL_API_SUBVERSION~'
PERL_API_VERSION='~PERL_API_VERSION~'
PERL_PATCHLEVEL='~PERL_VERSION~'
PERL_CONFIG_SH='true'
--- NEW FILE: perlhost.h ---
/* 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.
*/
#define CHECK_HOST_INTERP
#ifndef ___PerlHost_H___
#define ___PerlHost_H___
#include <signal.h>
#include "iperlsys.h"
#include "vmem.h"
#include "vdir.h"
[...2389 lines suppressed...]
dTHX;
int ret;
if (!dirname) {
errno = ENOENT;
return -1;
}
if (USING_WIDE()) {
WCHAR wBuffer[MAX_PATH];
A2WHELPER(dirname, wBuffer, sizeof(wBuffer));
ret = m_pvDir->SetCurrentDirectoryW(wBuffer);
}
else
ret = m_pvDir->SetCurrentDirectoryA((char*)dirname);
if(ret < 0) {
errno = ENOENT;
}
return ret;
}
#endif /* ___PerlHost_H___ */
--- NEW FILE: config_sh.PL ---
use 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 = <OPTF>);
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("../ext");
FindExt::set_static_extensions(split ' ', $opt{'static_ext'});
my @dynamic_ext = FindExt::dynamic_ext();
my @extensions = FindExt::extensions();
if (!$opt{'use5005threads'} || $opt{'use5005threads'} eq 'undef')
{
@dynamic_ext = grep(!/Thread/, at dynamic_ext);
@extensions = grep(!/Thread/, at extensions);
}
$opt{'nonxs_ext'} = join(' ',FindExt::nonxs_ext()) || ' ';
$opt{'static_ext'} = join(' ',FindExt::static_ext()) || ' ';
$opt{'dynamic_ext'} = join(' ', at dynamic_ext) || ' ';
$opt{'extensions'} = join(' ', at 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 (<PL>) {
if (/^#\s*define\s+(PERL_\w+)\s+([\d.]+)/) {
$opt{$1} = $2;
}
}
close PL;
}
else {
die "Can't find $pl_h: $!";
}
$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'} .= " patchlevel $opt{PERL_PATCHLEVEL}" if exists $opt{PERL_PATCHLEVEL};
$opt{'osvers'} = join '.', (Win32::GetOSVersion())[1,2];
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
if (defined(&Win32::IsWin95) && Win32::IsWin95()) {
$opt{d_flock} = 'undef';
$opt{d_link} = 'undef';
}
if ($opt{uselargefiles} ne 'define') {
$opt{lseeksize} = 4;
$opt{lseektype} = 'off_t';
}
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;
}
--- NEW FILE: pod.mak ---
CONVERTERS = pod2html pod2latex pod2man pod2text checkpods \
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
POD = \
perl.pod \
perl5004delta.pod \
perl5005delta.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 \
perl58delta.pod \
perlapi.pod \
perlapio.pod \
perlartistic.pod \
perlbook.pod \
perlboot.pod \
perlbot.pod \
perlcall.pod \
perlcheat.pod \
perlclib.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 \
perlnewmod.pod \
perlnumber.pod \
perlobj.pod \
perlop.pod \
perlopentut.pod \
perlothrtut.pod \
perlpacktut.pod \
perlpod.pod \
perlpodspec.pod \
perlport.pod \
perlre.pod \
perlref.pod \
perlreftut.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 \
perluniintro.pod \
perlutil.pod \
perlvar.pod \
perlxs.pod \
perlxstut.pod
MAN = \
perl.man \
perl5004delta.man \
perl5005delta.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 \
perl58delta.man \
perlapi.man \
perlapio.man \
perlartistic.man \
perlbook.man \
perlboot.man \
perlbot.man \
perlcall.man \
perlcheat.man \
perlclib.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 \
perlnewmod.man \
perlnumber.man \
perlobj.man \
perlop.man \
perlopentut.man \
perlothrtut.man \
perlpacktut.man \
perlpod.man \
perlpodspec.man \
perlport.man \
perlre.man \
perlref.man \
perlreftut.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 \
perluniintro.man \
perlutil.man \
perlvar.man \
perlxs.man \
perlxstut.man
HTML = \
perl.html \
perl5004delta.html \
perl5005delta.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 \
perl58delta.html \
perlapi.html \
perlapio.html \
perlartistic.html \
perlbook.html \
perlboot.html \
perlbot.html \
perlcall.html \
perlcheat.html \
perlclib.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 \
perlnewmod.html \
perlnumber.html \
perlobj.html \
perlop.html \
perlopentut.html \
perlothrtut.html \
perlpacktut.html \
perlpod.html \
perlpodspec.html \
perlport.html \
perlre.html \
perlref.html \
perlreftut.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 \
perluniintro.html \
perlutil.html \
perlvar.html \
perlxs.html \
perlxstut.html
# not perltoc.html
TEX = \
perl.tex \
perl5004delta.tex \
perl5005delta.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 \
perl58delta.tex \
perlapi.tex \
perlapio.tex \
perlartistic.tex \
perlbook.tex \
perlboot.tex \
perlbot.tex \
perlcall.tex \
perlcheat.tex \
perlclib.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 \
perlnewmod.tex \
perlnumber.tex \
perlobj.tex \
perlop.tex \
perlopentut.tex \
perlothrtut.tex \
perlpacktut.tex \
perlpod.tex \
perlpodspec.tex \
perlport.tex \
perlre.tex \
perlref.tex \
perlreftut.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 \
perluniintro.tex \
perlutil.tex \
perlvar.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: checkpods
@echo "checking..."; \
$(PERL) -I../lib checkpods $(POD)
# Dependencies.
pod2latex: pod2latex.PL ../lib/Config.pm
$(PERL) -I../lib pod2latex.PL
pod2html: pod2html.PL ../lib/Config.pm
$(PERL) -I ../lib pod2html.PL
pod2man: pod2man.PL ../lib/Config.pm
$(PERL) -I ../lib pod2man.PL
pod2text: pod2text.PL ../lib/Config.pm
$(PERL) -I ../lib pod2text.PL
checkpods: checkpods.PL ../lib/Config.pm
$(PERL) -I ../lib checkpods.PL
pod2usage: pod2usage.PL ../lib/Config.pm
$(PERL) -I ../lib pod2usage.PL
podchecker: podchecker.PL ../lib/Config.pm
$(PERL) -I ../lib podchecker.PL
podselect: podselect.PL ../lib/Config.pm
$(PERL) -I ../lib podselect.PL
compile: all
$(REALPERL) -I../lib ../utils/perlcc pod2latex -o pod2latex.exe -v 10 -log ../compilelog
$(REALPERL) -I../lib ../utils/perlcc pod2man -o pod2man.exe -v 10 -log ../compilelog
$(REALPERL) -I../lib ../utils/perlcc pod2text -o pod2text.exe -v 10 -log ../compilelog
$(REALPERL) -I../lib ../utils/perlcc checkpods -o checkpods.exe -v 10 -log ../compilelog
--- NEW FILE: vdir.h ---
/* vdir.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 ___VDir_H___
#define ___VDir_H___
/*
* Allow one slot for each possible drive letter
* and one additional slot for a UNC name
*/
const int driveCount = ('Z'-'A')+1+1;
class VDir
{
public:
VDir(int bManageDir = 1);
~VDir() {};
void Init(VDir* pDir, VMem *pMem);
void SetDefaultA(char const *pDefault);
void SetDefaultW(WCHAR const *pDefault);
char* MapPathA(const char *pInName);
WCHAR* MapPathW(const WCHAR *pInName);
int SetCurrentDirectoryA(char *lpBuffer);
int SetCurrentDirectoryW(WCHAR *lpBuffer);
inline int GetDefault(void) { return nDefault; };
inline char* GetCurrentDirectoryA(int dwBufSize, char *lpBuffer)
{
char* ptr = dirTableA[nDefault];
while (dwBufSize--)
{
if ((*lpBuffer++ = *ptr++) == '\0')
break;
}
return lpBuffer;
};
inline WCHAR* GetCurrentDirectoryW(int dwBufSize, WCHAR *lpBuffer)
{
WCHAR* ptr = dirTableW[nDefault];
while (dwBufSize--)
{
if ((*lpBuffer++ = *ptr++) == '\0')
break;
}
return lpBuffer;
};
DWORD CalculateEnvironmentSpace(void);
LPSTR BuildEnvironmentSpace(LPSTR lpStr);
protected:
int SetDirA(char const *pPath, int index);
void FromEnvA(char *pEnv, int index);
inline const char *GetDefaultDirA(void)
{
return dirTableA[nDefault];
};
inline void SetDefaultDirA(char const *pPath, int index)
{
SetDirA(pPath, index);
nDefault = index;
};
int SetDirW(WCHAR const *pPath, int index);
inline const WCHAR *GetDefaultDirW(void)
{
return dirTableW[nDefault];
};
inline void SetDefaultDirW(WCHAR const *pPath, int index)
{
SetDirW(pPath, index);
nDefault = index;
};
inline const char *GetDirA(int index)
{
char *ptr = dirTableA[index];
if (!ptr) {
/* simulate the existance of this drive */
ptr = szLocalBufferA;
ptr[0] = 'A' + index;
ptr[1] = ':';
ptr[2] = '\\';
ptr[3] = 0;
}
return ptr;
};
inline const WCHAR *GetDirW(int index)
{
WCHAR *ptr = dirTableW[index];
if (!ptr) {
/* simulate the existance of this drive */
ptr = szLocalBufferW;
ptr[0] = 'A' + index;
ptr[1] = ':';
ptr[2] = '\\';
ptr[3] = 0;
}
return ptr;
};
inline int DriveIndex(char chr)
{
if (chr == '\\' || chr == '/')
return ('Z'-'A')+1;
return (chr | 0x20)-'a';
};
VMem *pMem;
int nDefault, bManageDirectory;
char *dirTableA[driveCount];
char szLocalBufferA[MAX_PATH+1];
WCHAR *dirTableW[driveCount];
WCHAR szLocalBufferW[MAX_PATH+1];
};
VDir::VDir(int bManageDir /* = 1 */)
{
nDefault = 0;
bManageDirectory = bManageDir;
memset(dirTableA, 0, sizeof(dirTableA));
memset(dirTableW, 0, sizeof(dirTableW));
}
void VDir::Init(VDir* pDir, VMem *p)
{
int index;
DWORD driveBits;
int nSave;
char szBuffer[MAX_PATH*driveCount];
pMem = p;
if (pDir) {
for (index = 0; index < driveCount; ++index) {
SetDirW(pDir->GetDirW(index), index);
}
nDefault = pDir->GetDefault();
}
else {
nSave = bManageDirectory;
bManageDirectory = 0;
driveBits = GetLogicalDrives();
if (GetLogicalDriveStrings(sizeof(szBuffer), szBuffer)) {
char* pEnv = GetEnvironmentStrings();
char* ptr = szBuffer;
for (index = 0; index < driveCount; ++index) {
if (driveBits & (1<<index)) {
ptr += SetDirA(ptr, index) + 1;
FromEnvA(pEnv, index);
}
}
FreeEnvironmentStrings(pEnv);
}
SetDefaultA(".");
bManageDirectory = nSave;
}
}
int VDir::SetDirA(char const *pPath, int index)
{
char chr, *ptr;
int length = 0;
WCHAR wBuffer[MAX_PATH+1];
if (index < driveCount && pPath != NULL) {
length = strlen(pPath);
pMem->Free(dirTableA[index]);
ptr = dirTableA[index] = (char*)pMem->Malloc(length+2);
if (ptr != NULL) {
strcpy(ptr, pPath);
ptr += length-1;
chr = *ptr++;
if (chr != '\\' && chr != '/') {
*ptr++ = '\\';
*ptr = '\0';
}
MultiByteToWideChar(CP_ACP, 0, dirTableA[index], -1,
wBuffer, (sizeof(wBuffer)/sizeof(WCHAR)));
length = wcslen(wBuffer);
pMem->Free(dirTableW[index]);
dirTableW[index] = (WCHAR*)pMem->Malloc((length+1)*2);
if (dirTableW[index] != NULL) {
wcscpy(dirTableW[index], wBuffer);
}
}
}
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::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;
char szBuffer[MAX_PATH+1];
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) {
wcscpy(ptr, pPath);
ptr += length-1;
chr = *ptr++;
if (chr != '\\' && chr != '/') {
*ptr++ = '\\';
*ptr = '\0';
}
WideCharToMultiByte(CP_ACP, 0, dirTableW[index], -1, szBuffer, sizeof(szBuffer), NULL, NULL);
length = strlen(szBuffer);
pMem->Free(dirTableA[index]);
dirTableA[index] = (char*)pMem->Malloc(length+1);
if (dirTableA[index] != NULL) {
strcpy(dirTableA[index], szBuffer);
}
}
}
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 Nullch
* 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 Nullch
* 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___ */
--- NEW FILE: FindExt.pm ---
package FindExt;
our $VERSION = '1.01';
use strict;
use warnings;
my $no = join('|',qw(GDBM_File ODBM_File NDBM_File DB_File
Syslog SysV Langinfo));
$no = qr/^(?:$no)$/i;
my %ext;
my $ext;
my %static;
sub getcwd {
$ENV{'PWD'} = Win32::GetCwd();
$ENV{'PWD'} =~ s:\\:/:g ;
return $ENV{'PWD'};
}
sub set_static_extensions
{
# adjust results of scan_ext, and also save
# statics in case scan_ext hasn't been called yet.
%static = ();
for (@_) {
$static{$_} = 1;
$ext{$_} = 'static' if $ext{$_} && $ext{$_} eq 'dynamic';
}
}
sub scan_ext
{
my $here = getcwd();
my $dir = shift;
chdir($dir) || die "Cannot cd to $dir\n";
($ext = getcwd()) =~ s,/,\\,g;
find_ext('');
chdir($here) || die "Cannot cd to $here\n";
my @ext = extensions();
}
sub dynamic_ext
{
return sort grep $ext{$_} eq 'dynamic',keys %ext;
}
sub static_ext
{
return sort grep $ext{$_} eq 'static',keys %ext;
}
sub nonxs_ext
{
return sort grep $ext{$_} eq 'nonxs',keys %ext;
}
sub extensions
{
return sort grep $ext{$_} ne 'known',keys %ext;
}
sub known_extensions
{
# faithfully copy Configure in not including nonxs extensions for the nonce
return sort grep $ext{$_} ne 'nonxs',keys %ext;
}
sub is_static
{
return $ext{$_[0]} eq 'static'
}
# Function to recursively find available extensions, ignoring DynaLoader
# NOTE: recursion limit of 10 to prevent runaway in case of symlink madness
sub find_ext
{
opendir my $dh, '.';
my @items = grep { !/^\.\.?$/ } readdir $dh;
closedir $dh;
for my $xxx (@items) {
if ($xxx ne "DynaLoader") {
if (-f "$xxx/$xxx.xs") {
$ext{"$_[0]$xxx"} = $static{"$_[0]$xxx"} ? 'static' : 'dynamic';
} elsif (-f "$xxx/Makefile.PL") {
$ext{"$_[0]$xxx"} = 'nonxs';
} else {
if (-d $xxx && @_ < 10) {
chdir $xxx;
find_ext("$_[0]$xxx/", @_);
chdir "..";
}
}
$ext{"$_[0]$xxx"} = 'known' if $ext{"$_[0]$xxx"} && $xxx =~ $no;
}
}
# Special case: Add in threads/shared since it is not picked up by the
# recursive find above (and adding in general recursive finding breaks
# SDBM_File/sdbm). A.D. 10/25/2001.
if (!$_[0] && -d "threads/shared") {
$ext{"threads/shared"} = 'dynamic';
}
}
1;
--- NEW FILE: config_h.PL ---
#
BEGIN { warn "Running ".__FILE__."\n" };
BEGIN
{
require "../lib/Config.pm";
die "../Config.pm:$@" if $@;
Config::->import;
}
use File::Compare qw(compare);
use File::Copy qw(copy);
my $name = $0;
$name =~ s#^(.*)\.PL$#../$1.SH#;
my %opt;
while (@ARGV && $ARGV[0] =~ /^([\w_]+)=(.*)$/)
{
$opt{$1}=$2;
shift(@ARGV);
}
$opt{CONFIG_H} ||= 'config.h';
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 (<SH>)
{
last if /^sed/;
}
($term,$file,$pat) = /^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 (<SH>)
{
last if /^$term$/o;
s/\$([\w_]+)/Config($1)/eg;
s/`([^\`]*)`/BackTick($1)/eg;
munge();
s/\\\$/\$/g;
s#/[ *\*]*\*/#/**/#;
if (/^\s*#define\s+(PRIVLIB|SITELIB|VENDORLIB)_EXP/)
{
$_ = "#define ". $1 . "_EXP (win32_get_". lc($1) . "($patchlevel))\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,"../lib/CORE/config.h");
copy("$file.new","../lib/CORE/config.h") || die "Cannot copy:$!";
chmod(0444,"../lib/CORE/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;
}
--- NEW FILE: distclean.bat ---
@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*.dll
--- NEW FILE: splittree.pl ---
use DirHandle;
use AutoSplit;
sub splitthis {
my ($top,$base,$dest) = @_;
my $d = new DirHandle $base;
if (defined $d) {
while (defined($_ = $d->read)) {
next if $_ eq ".";
next if $_ eq "..";
my $entry = "$base\\$_";
my $entrywithouttop = $entry;
$entrywithouttop =~ s/^$top//;
if (-d $entry) {splitthis ($top,$entry,$dest);}
else {
next unless ($entry=~/pm$/i);
#print "Will run autosplit on $entry to $dest\n";
autosplit($entry,$dest,0,1,1);
};
};
};
}
splitthis $ARGV[0],$ARGV[0],$ARGV[1];
--- NEW FILE: runperl.c ---
#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
int
main(int argc, char **argv, char **env)
{
return RunPerl(argc, argv, env);
}
--- NEW FILE: config_H.vc64 ---
/*
* 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.vc64,v 1.1 2006-12-04 17:02:18 dslinux_cayenne Exp $
*/
/*
* Package name : perl5
* Source directory :
* Configuration time: Wed Mar 19 16:24:01 2003
* Configured by : gsar
* Target system :
*/
[...4332 lines suppressed...]
* 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
--- NEW FILE: win32io.c ---
#define PERL_NO_GET_CONTEXT
#define WIN32_LEAN_AND_MEAN
#define WIN32IO_IS_STDIO
#include <tchar.h>
#ifdef __GNUC__
#define Win32_Winsock
#endif
#include <windows.h>
#include <sys/stat.h>
#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);
DWORD high = (sizeof(offset) > sizeof(DWORD)) ? (DWORD)(offset >> 32) : 0;
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)
{
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
--- NEW FILE: win32sck.c ---
/* win32sck.c
*
* (c) 1995 Microsoft Corporation. All rights reserved.
* Developed by hip communications inc., http://info.hip.com/info/
* 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 <windows.h>
#include <ws2spi.h>
#include "EXTERN.h"
#include "perl.h"
#include "Win32iop.h"
#include <sys/socket.h>
#include <fcntl.h>
#include <sys/stat.h>
#include <assert.h>
#include <io.h>
/* thanks to Beverly Brown (beverly at 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 */
#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
#define StartSockets() \
STMT_START { \
if (!wsock_started) \
start_sockets(); \
set_socktype(); \
} STMT_END
#else
#define StartSockets() \
STMT_START { \
if (!wsock_started) { \
start_sockets(); \
set_socktype(); \
} \
} STMT_END
#endif
#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;
}
void
set_socktype(void)
{
#ifdef USE_SOCKETS_AS_HANDLES
#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
dTHX;
if (!w32_init_socktype) {
w32_init_socktype = 1;
}
#endif
#endif /* USE_SOCKETS_AS_HANDLES */
}
#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 at 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
Perl_fd_set dummy;
int i, fd, save_errno = errno;
FD_SET nrd, nwr, nex, *prd, *pwr, *pex;
/* winsock seems incapable of dealing with all three null fd_sets,
* so do the (millisecond) sleep as a special case
*/
if (!(rd || wr || ex)) {
if (timeout)
Sleep(timeout->tv_sec * 1000 +
timeout->tv_usec / 1000); /* do the best we can */
else
Sleep(UINT_MAX);
return 0;
}
StartSockets();
PERL_FD_ZERO(&dummy);
if (!rd)
rd = &dummy, prd = NULL;
else
prd = &nrd;
if (!wr)
wr = &dummy, pwr = NULL;
else
pwr = &nwr;
if (!ex)
ex = &dummy, pex = NULL;
else
pex = &nex;
FD_ZERO(&nrd);
FD_ZERO(&nwr);
FD_ZERO(&nex);
for (i = 0; i < nfds; i++) {
fd = TO_SOCKET(i);
if (PERL_FD_ISSET(i,rd))
FD_SET((unsigned)fd, &nrd);
if (PERL_FD_ISSET(i,wr))
FD_SET((unsigned)fd, &nwr);
if (PERL_FD_ISSET(i,ex))
FD_SET((unsigned)fd, &nex);
}
errno = save_errno;
SOCKET_TEST_ERROR(r = select(nfds, prd, pwr, pex, timeout));
save_errno = errno;
for (i = 0; i < nfds; i++) {
fd = TO_SOCKET(i);
if (PERL_FD_ISSET(i,rd) && !FD_ISSET(fd, &nrd))
PERL_FD_CLR(i,rd);
if (PERL_FD_ISSET(i,wr) && !FD_ISSET(fd, &nwr))
PERL_FD_CLR(i,wr);
if (PERL_FD_ISSET(i,ex) && !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 argp = (u_long)data;
int retval;
if (!wsock_started) {
Perl_croak_nocontext("ioctl implemented only on sockets");
/* NOTREACHED */
}
retval = ioctlsocket(TO_SOCKET(i), (long)u, &argp);
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;
}
--- NEW FILE: win32thread.h ---
#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 = 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 <process.h>
# 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
#if defined(USE_5005THREADS)
struct perl_thread;
int Perl_thread_create (struct perl_thread *thr, thread_func_t *fn);
void Perl_set_thread_self (struct perl_thread *thr);
void Perl_init_thread_intern (struct perl_thread *t);
#define SET_THREAD_SELF(thr) Perl_set_thread_self(thr)
#endif /* USE_5005THREADS */
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 */
--- NEW FILE: win32thread.c ---
#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_5005THREADS) || 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_5005THREADS) || 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
}
#ifdef USE_5005THREADS
void
Perl_init_thread_intern(struct perl_thread *athr)
{
#ifndef USE_DECLSPEC_THREAD
/*
* Initialize port-specific per-thread data in thr->i
* as only things we have there are just static areas for
* return values we don't _need_ to do anything but
* this is good practice:
*/
memset(&athr->i,0,sizeof(athr->i));
#endif
}
void
Perl_set_thread_self(struct perl_thread *thr)
{
/* Set thr->self. GetCurrentThread() retrurns a pseudo handle, need
this to convert it into a handle another thread can use.
*/
DuplicateHandle(GetCurrentProcess(),
GetCurrentThread(),
GetCurrentProcess(),
&thr->self,
0,
FALSE,
DUPLICATE_SAME_ACCESS);
}
int
Perl_thread_create(struct perl_thread *thr, thread_func_t *fn)
{
DWORD junk;
unsigned long th;
DEBUG_S(PerlIO_printf(Perl_debug_log,
"%p: create OS thread\n", thr));
#ifdef USE_RTL_THREAD_API
/* See comment about USE_RTL_THREAD_API in win32thread.h */
#if defined(__BORLANDC__)
th = _beginthreadNT(fn, /* start address */
0, /* stack size */
(void *)thr, /* parameters */
(void *)NULL, /* security attrib */
0, /* creation flags */
(unsigned long *)&junk); /* tid */
if (th == (unsigned long)-1)
th = 0;
#elif defined(_MSC_VER_)
th = _beginthreadex((void *)NULL, /* security attrib */
0, /* stack size */
fn, /* start address */
(void*)thr, /* parameters */
0, /* creation flags */
(unsigned *)&junk); /* tid */
#else /* compilers using CRTDLL.DLL only have _beginthread() */
th = _beginthread(fn, /* start address */
0, /* stack size */
(void*)thr); /* parameters */
if (th == (unsigned long)-1)
th = 0;
#endif
thr->self = (HANDLE)th;
#else /* !USE_RTL_THREAD_API */
thr->self = CreateThread(NULL, 0, fn, (void*)thr, 0, &junk);
#endif /* !USE_RTL_THREAD_API */
DEBUG_S(PerlIO_printf(Perl_debug_log,
"%p: OS thread = %p, id=%ld\n", thr, thr->self, junk));
return thr->self ? 0 : -1;
}
#endif
--- NEW FILE: perlexe.rc ---
PERLEXE ICON perlexe.ico
More information about the dslinux-commit
mailing list