pp_time
pp_tms
pp_trans
+pp_threadsv
pp_truncate
pp_uc
pp_ucfirst
{
int exitstatus;
+#ifdef USE_THREADS
+ MUTEX_INIT(&malloc_mutex);
+#endif
+
PERL_SYS_INIT(&argc,&argv);
perl_init_i18nl10n(1);
break;
case '-':
case 0:
+#ifdef WIN32
+ case '\r':
+#endif
case '\n':
case '\t':
break;
if (strEQ(origfilename,"-"))
scriptname = "";
if (fdscript >= 0) {
- rsfp = PerlIO_fdopen(fdscript,"r");
+ rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
#if defined(HAS_FCNTL) && defined(F_SETFD)
if (rsfp)
fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
rsfp = PerlIO_stdin();
}
else {
- rsfp = PerlIO_open(scriptname,"r");
+ rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
#if defined(HAS_FCNTL) && defined(F_SETFD)
if (rsfp)
fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
#define printf PerlIO_stdoutf
#endif
+#ifndef PERL_SCRIPT_MODE
+#define PERL_SCRIPT_MODE "r"
+#endif
+
/*
* nice_chunk and nice_chunk size need to be set
* and queried under the protection of sv_mutex
)
{
tryname = name;
- tryrsfp = PerlIO_open(name,"r");
+ tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
}
else {
AV *ar = GvAVn(incgv);
sv_setpvf(namesv, "%s/%s", dir, name);
#endif
tryname = SvPVX(namesv);
- tryrsfp = PerlIO_open(tryname, "r");
+ tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
if (tryrsfp) {
if (tryname[0] == '.' && tryname[1] == '/')
tryname += 2;
}
}
+#ifdef WIN32
+ win32_strip_return(sv);
+#endif
+
return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
}
char q;
if (s) {
char *nl = strrchr(s,'\n');
- if (nl)
+ if (nl)
*nl = '\0';
}
else if (multi_close < 32 || multi_close == 127) {
deprecate("comma-less variable list");
}
+#ifdef WIN32
+
+static I32
+win32_textfilter(int idx, SV *sv, int maxlen)
+{
+ I32 count = FILTER_READ(idx+1, sv, maxlen);
+ if (count > 0 && !maxlen)
+ win32_strip_return(sv);
+ return count;
+}
+#endif
+
+
void
lex_start(SV *line)
{
else
return 0 ; /* end of file */
}
+
}
return SvCUR(buf_sv);
}
return (*funcp)(idx, buf_sv, maxlen);
}
+
static char *
filter_gets(register SV *sv, register FILE *fp, STRLEN append)
{
+#ifdef WIN32FILTER
+ if (!rsfp_filters) {
+ filter_add(win32_textfilter,NULL);
+ }
+#endif
if (rsfp_filters) {
if (!append)
}
else
return (sv_gets(sv, fp, append));
-
}
}
goto retry;
case '\r':
+#ifndef WIN32CHEAT
warn("Illegal character \\%03o (carriage return)", '\r');
croak(
"(Maybe you didn't strip carriage returns after a network transfer?)\n");
+#endif
case ' ': case '\t': case '\f': case 013:
s++;
goto retry;
#
# uncomment next line if you want debug version of perl (big,slow)
-#CFG=Debug
+CFG=Debug
#
# set the install locations of the compiler include/libraries
..\taint.c \
..\toke.c \
..\universal.c \
- ..\util.c
+ ..\util.c \
+ ..\malloc.c
CORE_OBJ= ..\av.obj \
..\deb.obj \
..\taint.obj \
..\toke.obj \
..\universal.obj\
- ..\util.obj
+ ..\util.obj \
+ ..\malloc.obj
WIN32_C = perllib.c \
win32.c \
$(CORE_OBJ) : $(CORE_H)
$(DLL_OBJ) : $(CORE_H)
-perldll.def : $(MINIPERL) $(CONFIGPM)
+perldll.def : $(MINIPERL) $(CONFIGPM) makedef.pl
$(MINIPERL) -w makedef.pl $(DEFINES) $(CCTYPE) > perldll.def
$(PERLDLL): perldll.def $(CORE_OBJ) $(WIN32_OBJ) $(DLL_OBJ)
d_msgget='define'
d_msgrcv='define'
d_msgsnd='define'
-d_mymalloc='undef'
+d_mymalloc='define'
d_nice='undef'
d_oldarchlib='undef'
d_oldsock='undef'
d_msgget='define'
d_msgrcv='define'
d_msgsnd='define'
-d_mymalloc='undef'
+d_mymalloc='define'
d_nice='undef'
d_oldarchlib='undef'
d_oldsock='undef'
/* MYMALLOC:
* This symbol, if defined, indicates that we're using our own malloc.
*/
-/*#define MYMALLOC /**/
+#define MYMALLOC /**/
/* OLDARCHLIB:
* This variable, if defined, holds the name of the directory in
/* MYMALLOC:
* This symbol, if defined, indicates that we're using our own malloc.
*/
-/*#define MYMALLOC /**/
+#define MYMALLOC /**/
/* OLDARCHLIB:
* This variable, if defined, holds the name of the directory in
$define{$1} = 1 if ($flag =~ /^-D(\w+)$/);
}
+open(CFG,'config.h') || die "Cannot open config.h:$!";
+while (<CFG>)
+ {
+ $define{$1} = 1 if /^\s*#\s*define\s+(MYMALLOC)\b/;
+ }
+close(CFG);
+
warn join(' ',keys %define)."\n";
my $CCTYPE = shift || "MSVC";
+print "LIBRARY Perl\n";
+print "DESCRIPTION 'Perl interpreter, export autogenerated'\n";
+print "CODE LOADONCALL\n";
+print "DATA LOADONCALL NONSHARED MULTIPLE\n";
+print "EXPORTS\n";
+
$skip_sym=<<'!END!OF!SKIP!';
Perl_block_type
Perl_additem
Perl_opsave
!END!OF!SKIP!
+if ($define{'MYMALLOC'})
+ {
+ $skip_sym .= <<'!END!OF!SKIP!';
+Perl_safefree
+Perl_safemalloc
+Perl_saferealloc
+Perl_safecalloc
+!END!OF!SKIP!
+ emit_symbol('Perl_malloc');
+ emit_symbol('Perl_free');
+ emit_symbol('Perl_realloc');
+ emit_symbol('Perl_calloc');
+ }
+
unless ($define{'USE_THREADS'})
{
$skip_sym .= <<'!END!OF!SKIP!';
# sticks in front of them.
-print "LIBRARY Perl\n";
-print "DESCRIPTION 'Perl interpreter, export autogenerated'\n";
-print "CODE LOADONCALL\n";
-print "DATA LOADONCALL NONSHARED MULTIPLE\n";
-print "EXPORTS\n";
-
open (GLOBAL, "<../global.sym") || die "failed to open global.sym" . $!;
while (<GLOBAL>) {
my $symbol;
my $symbol;
next if (!/^[A-Za-z]/);
next if (/^#/);
+ s/\r//g;
$symbol = $_;
next if ($skip_sym =~ m/^$symbol/m);
$symbol = "Perl_".$symbol if ($define{'USE_THISPTR'}
win32_get_osfhandle
Perl_win32_init
Perl_init_os_extras
+Perl_getTHR
+Perl_setTHR
RunPerl
..\taint.c \
..\toke.c \
..\universal.c \
- ..\util.c
+ ..\util.c \
+ ..\malloc.c
CORE_OBJ= ..\av.obj \
..\deb.obj \
..\taint.obj \
..\toke.obj \
..\universal.obj\
- ..\util.obj
+ ..\util.obj \
+ ..\malloc.obj
WIN32_C = perllib.c \
win32.c \
int exitstatus;
PerlInterpreter *my_perl;
+#ifdef USE_THREADS
+ MUTEX_INIT(&malloc_mutex);
+#endif
+
PERL_SYS_INIT(&argc,&argv);
perl_init_i18nl10n(1);
return putchar(c);
}
+#ifdef MYMALLOC
+
+#ifndef USE_PERL_SBRK
+
+static char *committed = NULL;
+static char *base = NULL;
+static char *reserved = NULL;
+static char *brk = NULL;
+static DWORD pagesize = 0;
+static DWORD allocsize = 0;
+
+void *
+sbrk(int need)
+{
+ void *result;
+ if (!pagesize)
+ {SYSTEM_INFO info;
+ GetSystemInfo(&info);
+ /* Pretend page size is larger so we don't perpetually
+ * call the OS to commit just one page ...
+ */
+ pagesize = info.dwPageSize << 3;
+ allocsize = info.dwAllocationGranularity;
+ }
+ /* This scheme fails eventually if request for contiguous
+ * block is denied so reserve big blocks - this is only
+ * address space not memory ...
+ */
+ if (brk+need >= reserved)
+ {
+ DWORD size = 64*1024*1024;
+ char *addr;
+ if (committed && reserved && committed < reserved)
+ {
+ /* Commit last of previous chunk cannot span allocations */
+ addr = VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
+ if (addr)
+ committed = reserved;
+ }
+ /* Reserve some (more) space
+ * Note this is a little sneaky, 1st call passes NULL as reserved
+ * so lets system choose where we start, subsequent calls pass
+ * the old end address so ask for a contiguous block
+ */
+ addr = VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
+ if (addr)
+ {
+ reserved = addr+size;
+ if (!base)
+ base = addr;
+ if (!committed)
+ committed = base;
+ if (!brk)
+ brk = committed;
+ }
+ else
+ {
+ return (void *) -1;
+ }
+ }
+ result = brk;
+ brk += need;
+ if (brk > committed)
+ {
+ DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
+ char *addr = VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
+ if (addr)
+ {
+ committed += size;
+ }
+ else
+ return (void *) -1;
+ }
+ return result;
+}
+
+#endif
+#endif
+
DllExport void*
win32_malloc(size_t size)
{
free(block);
}
+
int
win32_open_osfhandle(long handle, int flags)
{
#endif
}
+#ifdef USE_BINMODE_SCRIPTS
+
+void
+win32_strip_return(SV *sv)
+{
+ char *s = SvPVX(sv);
+ char *e = s+SvCUR(sv);
+ char *d = s;
+ while (s < e)
+ {
+ if (*s == '\r' && s[1] == '\n')
+ {
+ *d++ = '\n';
+ s += 2;
+ }
+ else
+ {
+ *d++ = *s++;
+ }
+ }
+ SvCUR_set(sv,d-SvPVX(sv));
+}
+
+#endif
+
+
#include <sys/socket.h>
#include <netdb.h>
+#ifdef MYMALLOC
+#define EMBEDMYMALLOC /**/
+/* #define USE_PERL_SBRK /**/
+/* #define PERL_SBRK_VIA_MALLOC /**/
+#endif
+
+#ifdef PERLDLL
+#define PERL_CORE
+#endif
+
+#ifdef USE_BINMODE_SCRIPTS
+#define PERL_SCRIPT_MODE "rb"
+EXT void win32_strip_return(struct sv *sv);
+#else
+#define PERL_SCRIPT_MODE "r"
+#define win32_strip_return(sv) NOOP
+#endif
+
#endif /* _INC_WIN32_PERL5 */
#define puts win32_puts
#define getchar win32_getchar
#define putchar win32_putchar
+
+#if !defined(MYMALLOC) || !defined(PERLDLL)
+#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 WIN32IO_IS_STDIO
-#define WIN32SCK_IS_STDSCK
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#include "EXTERN.h"
#include <assert.h>
#include <io.h>
+#undef htonl
+#undef htons
+#undef ntohl
+#undef ntohs
+#undef inet_addr
+#undef inet_ntoa
+#undef socket
+#undef bind
+#undef listen
+#undef accept
+#undef connect
+#undef send
+#undef sendto
+#undef recv
+#undef recvfrom
+#undef shutdown
+#undef closesocket
+#undef ioctlsocket
+#undef setsockopt
+#undef getsockopt
+#undef getpeername
+#undef getsockname
+#undef gethostname
+#undef gethostbyname
+#undef gethostbyaddr
+#undef getprotobyname
+#undef getprotobynumber
+#undef getservbyname
+#undef getservbyport
+#undef select
+#undef endhostent
+#undef endnetent
+#undef endprotoent
+#undef endservent
+#undef getnetent
+#undef getnetbyname
+#undef getnetbyaddr
+#undef getprotoent
+#undef getservent
+#undef sethostent
+#undef setnetent
+#undef setprotoent
+#undef setservent
+
/* thanks to Beverly Brown (beverly@datacube.com) */
#ifdef USE_SOCKETS_AS_HANDLES
# define OPEN_SOCKET(x) _open_osfhandle(x,O_RDWR|O_BINARY)
/* select contributed by Vincent R. Slyngstad (vrs@ibeam.intel.com) */
int
-win32_select(int nfds, Perl_fd_set* rd, Perl_fd_set* wr, Perl_fd_set* ex, const struct timeval* timeout)
+win32_select(int nfds, int* rd, int* wr, int* ex, const struct timeval* timeout)
{
- int r;
-#ifdef USE_SOCKETS_AS_HANDLES
- Perl_fd_set dummy;
+ long r;
+ int dummy = 0;
int i, fd, bit, offset;
- FD_SET nrd, nwr, nex, *prd, *pwr, *pex;
+ FD_SET nrd, nwr, nex,*prd,*pwr,*pex;
- PERL_FD_ZERO(&dummy);
if (!rd)
rd = &dummy, prd = NULL;
else
FD_ZERO(&nex);
for (i = 0; i < nfds; i++) {
fd = TO_SOCKET(i);
- if (PERL_FD_ISSET(i,rd))
+ bit = 1L<<(i % (sizeof(int)*8));
+ offset = i / (sizeof(int)*8);
+ if (rd[offset] & bit)
FD_SET(fd, &nrd);
- if (PERL_FD_ISSET(i,wr))
+ if (wr[offset] & bit)
FD_SET(fd, &nwr);
- if (PERL_FD_ISSET(i,ex))
+ if (ex[offset] & bit)
FD_SET(fd, &nex);
}
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);
+ bit = 1L<<(i % (sizeof(int)*8));
+ offset = i / (sizeof(int)*8);
+ if (rd[offset] & bit) {
+ if (!__WSAFDIsSet(fd, &nrd))
+ rd[offset] &= ~bit;
+ }
+ if (wr[offset] & bit) {
+ if (!__WSAFDIsSet(fd, &nwr))
+ wr[offset] &= ~bit;
+ }
+ if (ex[offset] & bit) {
+ if (!__WSAFDIsSet(fd, &nex))
+ ex[offset] &= ~bit;
+ }
}
-#else
- SOCKET_TEST_ERROR(r = select(nfds, rd, wr, ex, timeout));
-#endif
return r;
}
#include "EXTERN.h"
#include "perl.h"
+__declspec(thread) struct thread *Perl_current_thread = NULL;
+
+void
+Perl_setTHR(struct thread *t)
+{
+ Perl_current_thread = t;
+}
+
+struct thread *
+Perl_getTHR(void)
+{
+ return Perl_current_thread;
+}
+
void
Perl_alloc_thread_key(void)
{
} \
} STMT_END
-#define THR ((struct thread *) TlsGetValue(thr_key))
+
#define THREAD_CREATE(t, f) Perl_thread_create(t, f)
#define THREAD_POST_CREATE(t) NOOP
#define THREAD_RET_TYPE DWORD WINAPI
typedef THREAD_RET_TYPE thread_func_t(void *);
+
START_EXTERN_C
+
+#if defined(PERLDLL) && (!defined(__BORLANDC__) || defined(_DLL))
+extern __declspec(thread) struct thread *Perl_current_thread;
+#define SET_THR(t) (Perl_current_thread = t)
+#define THR Perl_current_thread
+#else
+#define THR Perl_getTHR()
+#define SET_THR(t) Perl_setTHR(t)
+#endif
+
void Perl_alloc_thread_key _((void));
int Perl_thread_create _((struct thread *thr, thread_func_t *fn));
void Perl_set_thread_self _((struct thread *thr));
+struct thread *Perl_getTHR _((void));
+void Perl_setTHR _((struct thread *t));
+
END_EXTERN_C
#define INIT_THREADS NOOP
-#define ALLOC_THREAD_KEY Perl_alloc_thread_key()
+#define ALLOC_THREAD_KEY NOOP
#define SET_THREAD_SELF(thr) Perl_set_thread_self(thr)
#define JOIN(t, avp) \
croak("panic: JOIN"); \
} STMT_END
-#define SET_THR(t) \
- STMT_START { \
- if (TlsSetValue(thr_key, (void *) (t)) == 0) \
- croak("panic: TlsSetValue"); \
- } STMT_END
-
#define YIELD Sleep(0)
#endif /* _WIN32THREAD_H */
+
projects / p5sagit/p5-mst-13.2.git / commitdiff