#define gid pPerl->Perl_gid
#undef egid
#define egid pPerl->Perl_egid
+#undef endav
+#define endav pPerl->Perl_endav
#undef an
#define an pPerl->Perl_an
+#undef compcv
+#define compcv pPerl->Perl_compcv
#undef cop_seqmax
#define cop_seqmax pPerl->Perl_cop_seqmax
+#undef defstash
+#define defstash pPerl->Perl_defstash
#undef evalseq
#define evalseq pPerl->Perl_evalseq
+#undef hexdigit
+#define hexdigit pPerl->Perl_hexdigit
#undef sub_generation
#define sub_generation pPerl->Perl_sub_generation
#undef origenviron
#define markstack_ptr pPerl->Perl_markstack_ptr
#undef markstack_max
#define markstack_max pPerl->Perl_markstack_max
+#undef maxo
+#define maxo pPerl->Perl_maxo
+#undef op_mask
+#define op_mask pPerl->Perl_op_mask
#undef curpad
#define curpad pPerl->Perl_curpad
#undef Sv
#define Sv pPerl->Perl_Sv
#undef Xpv
#define Xpv pPerl->Perl_Xpv
-#undef buf
-#define buf pPerl->Perl_buf
#undef tokenbuf
#define tokenbuf pPerl->Perl_tokenbuf
#undef statbuf
#define gen_constant_list pPerl->Perl_gen_constant_list
#undef getlogin
#define getlogin pPerl->getlogin
+#undef get_op_descs
+#define get_op_descs pPerl->Perl_get_op_descs
+#undef get_op_names
+#define get_op_names pPerl->Perl_get_op_names
#undef gp_free
#define gp_free pPerl->Perl_gp_free
#undef gp_ref
#define mg_free pPerl->Perl_mg_free
#undef mg_get
#define mg_get pPerl->Perl_mg_get
-#undef mg_Len
-#define mg_Len pPerl->mg_Len
#undef mg_magical
#define mg_magical pPerl->Perl_mg_magical
#undef mg_set
#define save_clearsv pPerl->Perl_save_clearsv
#undef save_delete
#define save_delete pPerl->Perl_save_delete
+#undef save_destructor
+#define save_destructor pPerl->Perl_save_destructor
#undef save_freesv
#define save_freesv pPerl->Perl_save_freesv
#undef save_freeop
#define sighandler pPerl->Perl_sighandler
#undef skipspace
#define skipspace pPerl->Perl_skipspace
-#undef sortcv
-#define sortcv pPerl->sortcv
-#undef sortcmp
-#define sortcmp pPerl->sortcmp
#undef stack_grow
#define stack_grow pPerl->Perl_stack_grow
#undef start_subparse
#define warn pPerl->Perl_warn
+#undef piMem
+#define piMem (pPerl->piMem)
+#undef piENV
+#define piENV (pPerl->piENV)
+#undef piStdIO
+#define piStdIO (pPerl->piStdIO)
+#undef piLIO
+#define piLIO (pPerl->piLIO)
+#undef piDir
+#define piDir (pPerl->piDir)
+#undef piSock
+#define piSock (pPerl->piSock)
+#undef piProc
+#define piProc (pPerl->piProc)
+
#undef SAVETMPS
#define SAVETMPS pPerl->SaveTmps()
#undef FREETMPS
#define FREETMPS pPerl->FreeTmps()
+#ifndef NO_XSLOCKS
+#undef closedir
+#undef opendir
+#undef stdin
+#undef stdout
+#undef stderr
+#undef feof
+#undef ferror
+#undef fgetpos
+#undef ioctl
+#undef getlogin
+#undef setjmp
+
+#define mkdir PerlDir_mkdir
+#define chdir PerlDir_chdir
+#define rmdir PerlDir_rmdir
+#define closedir PerlDir_close
+#define opendir PerlDir_open
+#define readdir PerlDir_read
+#define rewinddir PerlDir_rewind
+#define seekdir PerlDir_seek
+#define telldir PerlDir_tell
+#define putenv PerlEnv_putenv
+#define getenv PerlEnv_getenv
+#define stdin PerlIO_stdin
+#define stdout PerlIO_stdout
+#define stderr PerlIO_stderr
+#define fopen PerlIO_open
+#define fclose PerlIO_close
+#define feof PerlIO_eof
+#define ferror PerlIO_error
+#define fclearerr PerlIO_clearerr
+#define getc PerlIO_getc
+#define fputc(c, f) PerlIO_putc(f,c)
+#define fputs(s, f) PerlIO_puts(f,s)
+#define fflush PerlIO_flush
+#define ungetc(c, f) PerlIO_ungetc((f),(c))
+#define fileno PerlIO_fileno
+#define fdopen PerlIO_fdopen
+#define freopen PerlIO_reopen
+#define fread(b,s,c,f) PerlIO_read((f),(b),(s*c))
+#define fwrite(b,s,c,f) PerlIO_write((f),(b),(s*c))
+#define setbuf PerlIO_setbuf
+#define setvbuf PerlIO_setvbuf
+#define setlinebuf PerlIO_setlinebuf
+#define stdoutf PerlIO_stdoutf
+#define vfprintf PerlIO_vprintf
+#define ftell PerlIO_tell
+#define fseek PerlIO_seek
+#define fgetpos PerlIO_getpos
+#define fsetpos PerlIO_setpos
+#define frewind PerlIO_rewind
+#define tmpfile PerlIO_tmpfile
+#define access PerlLIO_access
+#define chmod PerlLIO_chmod
+#define chsize PerlLIO_chsize
+#define close PerlLIO_close
+#define dup PerlLIO_dup
+#define dup2 PerlLIO_dup2
+#define flock PerlLIO_flock
+#define fstat PerlLIO_fstat
+#define ioctl PerlLIO_ioctl
+#define isatty PerlLIO_isatty
+#define lseek PerlLIO_lseek
+#define lstat PerlLIO_lstat
+#define mktemp PerlLIO_mktemp
+#define open PerlLIO_open
+#define read PerlLIO_read
+#define rename PerlLIO_rename
+#define setmode PerlLIO_setmode
+#define stat PerlLIO_stat
+#define tmpnam PerlLIO_tmpnam
+#define umask PerlLIO_umask
+#define unlink PerlLIO_unlink
+#define utime PerlLIO_utime
+#define write PerlLIO_write
+#define malloc PerlMem_malloc
+#define realloc PerlMem_realloc
+#define free PerlMem_free
+#define abort PerlProc_abort
+#define exit PerlProc_exit
+#define _exit PerlProc__exit
+#define execl PerlProc_execl
+#define execv PerlProc_execv
+#define execvp PerlProc_execvp
+#define getuid PerlProc_getuid
+#define geteuid PerlProc_geteuid
+#define getgid PerlProc_getgid
+#define getegid PerlProc_getegid
+#define getlogin PerlProc_getlogin
+#define kill PerlProc_kill
+#define killpg PerlProc_killpg
+#define pause PerlProc_pause
+#define popen PerlProc_popen
+#define pclose PerlProc_pclose
+#define pipe PerlProc_pipe
+#define setuid PerlProc_setuid
+#define setgid PerlProc_setgid
+#define sleep PerlProc_sleep
+#define times PerlProc_times
+#define wait PerlProc_wait
+#define setjmp PerlProc_setjmp
+#define longjmp PerlProc_longjmp
+#define signal PerlProc_signal
+#define htonl PerlSock_htonl
+#define htons PerlSock_htons
+#define ntohs PerlSock_ntohl
+#define ntohl PerlSock_ntohs
+#define accept PerlSock_accept
+#define bind PerlSock_bind
+#define connect PerlSock_connect
+#define endhostent PerlSock_endhostent
+#define endnetent PerlSock_endnetent
+#define endprotoent PerlSock_endprotoent
+#define endservent PerlSock_endservent
+#define gethostbyaddr PerlSock_gethostbyaddr
+#define gethostbyname PerlSock_gethostbyname
+#define gethostent PerlSock_gethostent
+#define gethostname PerlSock_gethostname
+#define getnetbyaddr PerlSock_getnetbyaddr
+#define getnetbyname PerlSock_getnetbyname
+#define getnetent PerlSock_getnetent
+#define getpeername PerlSock_getpeername
+#define getprotobyname PerlSock_getprotobyname
+#define getprotobynumber PerlSock_getprotobynumber
+#define getprotoent PerlSock_getprotoent
+#define getservbyname PerlSock_getservbyname
+#define getservbyport PerlSock_getservbyport
+#define getservent PerlSock_getservent
+#define getsockname PerlSock_getsockname
+#define getsockopt PerlSock_getsockopt
+#define inet_addr PerlSock_inet_addr
+#define inet_ntoa PerlSock_inet_ntoa
+#define listen PerlSock_listen
+#define recvfrom PerlSock_recvfrom
+#define select PerlSock_select
+#define send PerlSock_send
+#define sendto PerlSock_sendto
+#define sethostent PerlSock_sethostent
+#define setnetent PerlSock_setnetent
+#define setprotoent PerlSock_setprotoent
+#define setservent PerlSock_setservent
+#define setsockopt PerlSock_setsockopt
+#define shutdown PerlSock_shutdown
+#define socket PerlSock_socket
+#define socketpair PerlSock_socketpair
+#endif /* NO_XSLOCKS */
+
+#undef THIS
+#define THIS pPerl
+#undef THIS_
+#define THIS_ pPerl,
+
#ifdef WIN32
#undef errno
-#define errno pPerl->ErrorNo()
-#undef pVtbl
-#define pVtbl (pPerl->GetpVtbl())
-#undef g_lpObj
-#define g_lpObj pPerl->Perl_g_lpObj
+#define errno ErrorNo()
+#undef ErrorNo
+#define ErrorNo pPerl->ErrorNo
#undef LastOLEError
#define LastOLEError pPerl->Perl_LastOLEError
#undef bOleInit
--- /dev/null
+#ifndef __XSLock_h__
+#define __XSLock_h__
+
+class XSLockManager
+{
+public:
+ XSLockManager() { InitializeCriticalSection(&cs); };
+ ~XSLockManager() { DeleteCriticalSection(&cs); };
+ void Enter(void) { EnterCriticalSection(&cs); };
+ void Leave(void) { LeaveCriticalSection(&cs); };
+protected:
+ CRITICAL_SECTION cs;
+};
+
+XSLockManager g_XSLock;
+
+class XSLock
+{
+public:
+ XSLock() { g_XSLock.Enter(); };
+ ~XSLock() { g_XSLock.Leave(); };
+};
+
+CPerlObj* pPerl;
+
+#undef dXSARGS
+#define dXSARGS \
+ dSP; dMARK; \
+ I32 ax = mark - stack_base + 1; \
+ I32 items = sp - mark; \
+ XSLock localLock; \
+ ::pPerl = pPerl
+
+
+#endif
#ifdef PERL_OBJECT
#include "ObjXSub.h"
-#endif
\ No newline at end of file
+#ifndef NO_XSLOCKS
+#ifdef WIN32
+#include "XSLock.h"
+#endif /* WIN32 */
+#endif /* NO_XSLOCKS */
+#endif /* PERL_OBJECT */
SvREFCNT_dec(AvARRAY(av)[--key]);
}
Safefree(AvALLOC(av));
+#ifdef PERL_OBJECT
+ (((XPVAV*) SvANY(av))->xav_array) = 0;
+ /* the following line is is a problem with VC */
+ /* AvARRAY(av) = 0; */
+#else
AvARRAY(av) = 0;
+#endif
AvALLOC(av) = 0;
SvPVX(av) = 0;
AvMAX(av) = AvFILLp(av) = -1;
#define scrgv (Perl_Vars.Gscrgv)
#define sh_path (Perl_Vars.Gsh_path)
#define sighandlerp (Perl_Vars.Gsighandlerp)
-#define sort_mutex (Perl_Vars.Gsort_mutex)
#define sub_generation (Perl_Vars.Gsub_generation)
#define subline (Perl_Vars.Gsubline)
#define subname (Perl_Vars.Gsubname)
#define Gscrgv scrgv
#define Gsh_path sh_path
#define Gsighandlerp sighandlerp
-#define Gsort_mutex sort_mutex
#define Gsub_generation sub_generation
#define Gsubline subline
#define Gsubname subname
#define scrgv Perl_scrgv
#define sh_path Perl_sh_path
#define sighandlerp Perl_sighandlerp
-#define sort_mutex Perl_sort_mutex
#define sub_generation Perl_sub_generation
#define subline Perl_subline
#define subname Perl_subname
static void
-dl_generic_private_init(void) /* called by dl_*.xs dl_private_init() */
+dl_generic_private_init(CPERLarg) /* called by dl_*.xs dl_private_init() */
{
char *perl_dl_nonlazy;
#ifdef DEBUGGING
/* SaveError() takes printf style args and saves the result in LastError */
static void
-SaveError(char* pat, ...)
+SaveError(CPERLarg_ char* pat, ...)
{
va_list args;
char *message;
curcop = &compiling;
cxstack_ix = -1;
cxstack_max = 128;
+ chopset = " \n-";
#ifdef USE_THREADS
threadsv_names = THREADSV_NAMES;
- chopset = " \n-";
tmps_ix = -1;
tmps_floor = -1;
- curcop = &compiling;
- cxstack_ix = -1;
- cxstack_max = 128;
#endif
maxo = MAXO;
sh_path = SH_PATH;
return PerlProc_aspawn(vreally, vmark, vsp);
}
+EXTERN_C void boot_DynaLoader _((CPERLarg_ CV* cv));
+
+void CPerlObj::BootDynaLoader(void)
+{
+ char *file = __FILE__;
+ dXSUB_SYS;
+ newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
+}
+
#endif /* WIN32 */
#endif /* PERL_OBJECT */
virtual int Ungetc(PerlIO*,int, int &err) = 0;
virtual int Fileno(PerlIO*, int &err) = 0;
virtual PerlIO* Fdopen(int, const char *, int &err) = 0;
+ virtual PerlIO* Reopen(const char*, const char*, PerlIO*, int &err) = 0;
virtual SSize_t Read(PerlIO*,void *,Size_t, int &err) = 0;
virtual SSize_t Write(PerlIO*,const void *,Size_t, int &err) = 0;
+ virtual void SetBuf(PerlIO *, char*, int &err) = 0;
+ virtual int SetVBuf(PerlIO *, char*, int, Size_t, int &err) = 0;
virtual void SetCnt(PerlIO *, int, int &err) = 0;
virtual void SetPtrCnt(PerlIO *, char *, int, int& err) = 0;
virtual void Setlinebuf(PerlIO*, int &err) = 0;
*/
#ifdef PERL_OBJECT
-static void UnwindHandler(void *pPerl, void *ptr)
-{
- ((CPerlObj*)pPerl)->unwind_handler_stack(ptr);
-}
-static void RestoreMagic(void *pPerl, void *ptr)
-{
- ((CPerlObj*)pPerl)->restore_magic(ptr);
-}
-#define UNWINDHANDLER UnwindHandler
-#define RESTOREMAGIC RestoreMagic
#define VTBL this->*vtbl
#else
typedef struct magic_state MGS;
static void restore_magic _((void *p));
-#define UNWINDHANDLER unwind_handler_stack
-#define RESTOREMAGIC restore_magic
#define VTBL *vtbl
#endif
mgs->mgs_sv = sv;
mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
- SAVEDESTRUCTOR(RESTOREMAGIC, mgs);
+ SAVEDESTRUCTOR(restore_magic, mgs);
SvMAGICAL_off(sv);
SvREADONLY_off(sv);
}
U32
-mg_len(SV *sv)
+mg_length(SV *sv)
{
MAGIC* mg;
char *junk;
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
MGVTBL* vtbl = mg->mg_virtual;
- if (vtbl && vtbl->svt_len) {
+ if (vtbl && (vtbl->svt_len != NULL)) {
MGS mgs;
ENTER;
/* omit MGf_GSKIP -- not changed here */
- len = (*vtbl->svt_len)(sv, mg);
+ len = (VTBL->svt_len)(sv, mg);
LEAVE;
return len;
}
if (vtbl && (vtbl->svt_free != NULL))
(VTBL->svt_free)(sv, mg);
if (mg->mg_ptr && mg->mg_type != 'g')
- if (mg->mg_length >= 0)
+ if (mg->mg_len >= 0)
Safefree(mg->mg_ptr);
- else if (mg->mg_length == HEf_SVKEY)
+ else if (mg->mg_len == HEf_SVKEY)
SvREFCNT_dec((SV*)mg->mg_ptr);
if (mg->mg_flags & MGf_REFCOUNTED)
SvREFCNT_dec(mg->mg_obj);
return 0;
}
-static int
+STATIC int
magic_methcall(MAGIC *mg, char *meth, I32 flags, int n, SV *val)
{
dSP;
PUSHs(mg->mg_obj);
if (n > 1) {
if (mg->mg_ptr) {
- if (mg->mg_length >= 0)
- PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_length)));
- else if (mg->mg_length == HEf_SVKEY)
+ if (mg->mg_len >= 0)
+ PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
+ else if (mg->mg_len == HEf_SVKEY)
PUSHs((SV*)mg->mg_ptr);
}
else if (mg->mg_type == 'p') {
- PUSHs(sv_2mortal(newSViv(mg->mg_length)));
+ PUSHs(sv_2mortal(newSViv(mg->mg_len)));
}
}
if (n > 2) {
if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
mg = mg_find(lsv, 'g');
- if (mg && mg->mg_length >= 0) {
+ if (mg && mg->mg_len >= 0) {
dTHR;
- sv_setiv(sv, mg->mg_length + curcop->cop_arybase);
+ sv_setiv(sv, mg->mg_len + curcop->cop_arybase);
return 0;
}
}
mg = mg_find(lsv, 'g');
}
else if (!SvOK(sv)) {
- mg->mg_length = -1;
+ mg->mg_len = -1;
return 0;
}
len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
}
else if (pos > len)
pos = len;
- mg->mg_length = pos;
+ mg->mg_len = pos;
mg->mg_flags &= ~MGf_MINMATCH;
return 0;
magic_gettaint(SV *sv, MAGIC *mg)
{
dTHR;
- TAINT_IF((mg->mg_length & 1) ||
- (mg->mg_length & 2) && mg->mg_obj == sv); /* kludge */
+ TAINT_IF((mg->mg_len & 1) ||
+ (mg->mg_len & 2) && mg->mg_obj == sv); /* kludge */
return 0;
}
dTHR;
if (localizing) {
if (localizing == 1)
- mg->mg_length <<= 1;
+ mg->mg_len <<= 1;
else
- mg->mg_length >>= 1;
+ mg->mg_len >>= 1;
}
else if (tainted)
- mg->mg_length |= 1;
+ mg->mg_len |= 1;
else
- mg->mg_length &= ~1;
+ mg->mg_len &= ~1;
return 0;
}
int
magic_setmglob(SV *sv, MAGIC *mg)
{
- mg->mg_length = -1;
+ mg->mg_len = -1;
SvSCREAM_off(sv);
return 0;
}
if (mg->mg_ptr) {
Safefree(mg->mg_ptr);
mg->mg_ptr = NULL;
- mg->mg_length = -1;
+ mg->mg_len = -1;
}
return 0;
}
if (flags & 1) {
savestack_ix += 5; /* Protect save in progress. */
o_save_i = savestack_ix;
- SAVEDESTRUCTOR(UNWINDHANDLER, (void*)&flags);
+ SAVEDESTRUCTOR(unwind_handler_stack, (void*)&flags);
}
if (flags & 4)
markstack_ptr++; /* Protect mark. */
U8 mg_flags;
SV* mg_obj;
char* mg_ptr;
- I32 mg_length;
+ I32 mg_len;
};
#define MGf_TAINTEDDIR 1
#define MgTAINTEDDIR_on(mg) (mg->mg_flags |= MGf_TAINTEDDIR)
#define MgTAINTEDDIR_off(mg) (mg->mg_flags &= ~MGf_TAINTEDDIR)
-#define MgPV(mg,lp) (((lp = (mg)->mg_length) == HEf_SVKEY) ? \
+#define MgPV(mg,lp) (((lp = (mg)->mg_len) == HEf_SVKEY) ? \
SvPV((SV*)((mg)->mg_ptr),lp) : \
(mg)->mg_ptr)
#define magic_getuvar CPerlObj::Perl_magic_getuvar
#undef magic_len
#define magic_len CPerlObj::Perl_magic_len
+#undef magic_methcall
+#define magic_methcall CPerlObj::magic_methcall
#undef magic_methpack
#define magic_methpack CPerlObj::magic_methpack
#undef magic_nextpack
#define magic_setuvar CPerlObj::Perl_magic_setuvar
#undef magic_setvec
#define magic_setvec CPerlObj::Perl_magic_setvec
+#undef magic_sizepack
+#define magic_sizepack CPerlObj::Perl_magic_sizepack
#undef magic_wipepack
#define magic_wipepack CPerlObj::Perl_magic_wipepack
#undef magicname
#define mg_free CPerlObj::Perl_mg_free
#undef mg_get
#define mg_get CPerlObj::Perl_mg_get
-#undef mg_len
-#define mg_len CPerlObj::Perl_mg_len
+#undef mg_length
+#define mg_length CPerlObj::mg_length
#undef mg_magical
#define mg_magical CPerlObj::Perl_mg_magical
#undef mg_set
#define mg_set CPerlObj::Perl_mg_set
+#undef mg_size
+#define mg_size CPerlObj::Perl_mg_size
#undef missingterm
#define missingterm CPerlObj::missingterm
#undef mod
#define push_scope CPerlObj::Perl_push_scope
#undef pregcomp
#define pregcomp CPerlObj::Perl_pregcomp
+#undef qsortsv
+#define qsortsv CPerlObj::qsortsv
#undef ref
#define ref CPerlObj::Perl_ref
#undef refkids
#define skipspace CPerlObj::Perl_skipspace
#undef sortcv
#define sortcv CPerlObj::sortcv
-#undef sortcmp
-#define sortcmp CPerlObj::sortcmp
-#undef sortcmp_locale
-#define sortcmp_locale CPerlObj::sortcmp_locale
#ifndef PERL_OBJECT
#undef stack_base
#define stack_base CPerlObj::Perl_stack_base
MUTEX_INIT(&threads_mutex);
COND_INIT(&nthreads_cond);
-#ifdef PERL_OBJECT
- MUTEX_INIT(&sort_mutex);
-#endif
-
thr = init_main_thread();
#endif /* USE_THREADS */
hints = 0; /* Reset hints. Should hints be per-interpreter ? */
DEBUG_P(debprofdump());
-#ifdef PERL_OBJECT
- MUTEX_DESTROY(&sort_mutex);
-#endif
#ifdef USE_THREADS
MUTEX_DESTROY(&sv_mutex);
MUTEX_DESTROY(&eval_mutex);
#endif
{
#ifdef PERL_OBJECT
+ Safefree(this);
#else
if (!(curinterp = sv_interp))
return;
CvPADLIST(compcv) = comppadlist;
boot_core_UNIVERSAL();
+#if defined(WIN32) && defined(PERL_OBJECT)
+ BootDynaLoader();
+#endif
if (xsinit)
(*xsinit)(THIS); /* in case linked C routines want magical variables */
#if defined(VMS) || defined(WIN32) || defined(DJGPP)
#define CPERLscope(x) x
#define CPERLproto
#define CPERLproto_
-#define CPERLarg
+#define CPERLarg void
#define CPERLarg_
#define THIS
#define THIS_
I32 any_i32;
IV any_iv;
long any_long;
-#ifdef PERL_OBJECT
- void (*any_dptr) _((void*, void*));
-#else
- void (*any_dptr) _((void*));
-#endif
+ void (CPERLscope(*any_dptr)) _((void*));
};
#ifdef USE_THREADS
#define PerlIO_ungetc(f,c) piStdIO->Ungetc((f),(c), ErrorNo())
#define PerlIO_fileno(f) piStdIO->Fileno((f), ErrorNo())
#define PerlIO_fdopen(f, s) piStdIO->Fdopen((f),(s), ErrorNo())
+#define PerlIO_reopen(p, m, f) piStdIO->Reopen((p), (m), (f), ErrorNo())
#define PerlIO_read(f,buf,count) (SSize_t)piStdIO->Read((f), (buf), (count), ErrorNo())
#define PerlIO_write(f,buf,count) piStdIO->Write((f), (buf), (count), ErrorNo())
+#define PerlIO_setbuf(f,b) piStdIO->SetBuf((f), (b), ErrorNo())
+#define PerlIO_setvbuf(f,b,t,s) piStdIO->SetVBuf((f), (b), (t), (s), ErrorNo())
#define PerlIO_set_cnt(f,c) piStdIO->SetCnt((f), (c), ErrorNo())
#define PerlIO_set_ptrcnt(f,p,c) piStdIO->SetPtrCnt((f), (p), (c), ErrorNo())
#define PerlIO_setlinebuf(f) piStdIO->Setlinebuf((f), ErrorNo())
#endif
#endif /* USE_THREADS */
#ifdef PERL_OBJECT
-/* TODO: move into thread section */
-PERLVAR(Gsort_mutex, CRITICAL_SECTION) /* Mutex for qsort */
#ifdef WIN32
PERLVAR(Gerror_no, int) /* errno for each interpreter */
#endif
Safefree(ysave);
}
-#ifdef PERL_OBJECT
-static void YYDestructor(void *pPerl, void *ptr)
-{
- ((CPerlObj*)pPerl)->yydestruct(ptr);
-}
-#define YYDESTRUCT YYDestructor
-#else
-#define YYDESTRUCT yydestruct
-#endif
-
int
yyparse(void)
{
#endif
struct ysv *ysave = (struct ysv*)safemalloc(sizeof(struct ysv));
- SAVEDESTRUCTOR(YYDESTRUCT, ysave);
+ SAVEDESTRUCTOR(yydestruct, ysave);
ysave->oldyydebug = yydebug;
ysave->oldyynerrs = yynerrs;
ysave->oldyyerrflag = yyerrflag;
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
mg = mg_find(sv, 'g');
- if (mg && mg->mg_length >= 0) {
- PUSHi(mg->mg_length + curcop->cop_arybase);
+ if (mg && mg->mg_len >= 0) {
+ PUSHi(mg->mg_len + curcop->cop_arybase);
RETURN;
}
}
}
}
-
-#ifdef PERL_OBJECT
-static CPerlObj *pSortPerl;
-static int SortCv(const void *a, const void *b)
-{
- return pSortPerl->sortcv(a, b);
-}
-#endif
-
PP(pp_sort)
{
djSP; dMARK; dORIGMARK;
(void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
}
sortcxix = cxstack_ix;
-
-#ifdef PERL_OBJECT
- MUTEX_LOCK(&sort_mutex);
- pSortPerl = this;
- qsortsv((myorigmark+1), max, SortCv);
- MUTEX_UNLOCK(&sort_mutex);
-#else
qsortsv((myorigmark+1), max, sortcv);
-#endif
POPBLOCK(cx,curpm);
SWITCHSTACK(sortstack, oldstack);
else {
if (max > 1) {
MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
-#ifdef PERL_OBJECT
- /* XXX sort_mutex is probably not needed since qsort is now
- * internal GSAR */
- MUTEX_LOCK(&sort_mutex);
- pSortPerl = this;
qsortsv(ORIGMARK+1, max,
(op->op_private & OPpLOCALE) ? sv_cmp_locale : sv_cmp);
- MUTEX_UNLOCK(&sort_mutex);
-#else
- qsortsv(ORIGMARK+1, max,
- (op->op_private & OPpLOCALE) ? sv_cmp_locale : sv_cmp);
-#endif
}
}
stack_sp = ORIGMARK + max;
/* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
*/
+#ifdef PERL_OBJECT
+#define qsort_cmp(elt1, elt2) \
+ ((this->*compare)(array[elt1], array[elt2]))
+#else
#define qsort_cmp(elt1, elt2) \
((*compare)(array[elt1], array[elt2]))
+#endif
#ifdef QSORT_ORDER_GUESS
#define QSORT_NOTICE_SWAP swapped++;
/* ****************************************************************** qsort */
void
+#ifdef PERL_OBJECT
+qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
+#else
qsortsv(
SV ** array,
size_t num_elts,
I32 (*compare)(SV *a, SV *b))
+#endif
{
register SV * temp;
rx->startp[0] = 0;
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
MAGIC* mg = mg_find(TARG, 'g');
- if (mg && mg->mg_length >= 0) {
- rx->endp[0] = rx->startp[0] = s + mg->mg_length;
+ if (mg && mg->mg_len >= 0) {
+ rx->endp[0] = rx->startp[0] = s + mg->mg_len;
minmatch = (mg->mg_flags & MGf_MINMATCH);
update_minmatch = 0;
}
mg = mg_find(TARG, 'g');
}
if (rx->startp[0]) {
- mg->mg_length = rx->endp[0] - rx->subbeg;
+ mg->mg_len = rx->endp[0] - rx->subbeg;
if (rx->startp[0] == rx->endp[0])
mg->mg_flags |= MGf_MINMATCH;
else
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
MAGIC* mg = mg_find(TARG, 'g');
if (mg)
- mg->mg_length = -1;
+ mg->mg_len = -1;
}
}
LEAVE_SCOPE(oldsave);
VIRTUAL MAGIC* mg_find _((SV* sv, int type));
VIRTUAL int mg_free _((SV* sv));
VIRTUAL int mg_get _((SV* sv));
-VIRTUAL U32 mg_len _((SV* sv));
+VIRTUAL U32 mg_length _((SV* sv));
VIRTUAL void mg_magical _((SV* sv));
VIRTUAL int mg_set _((SV* sv));
VIRTUAL I32 mg_size _((SV* sv));
VIRTUAL OP* newPMOP _((I32 type, I32 flags));
VIRTUAL OP* newPVOP _((I32 type, I32 flags, char* pv));
VIRTUAL SV* newRV _((SV* ref));
-#if !defined(__GNUC__) && (defined(CRIPPLED_CC) || defined(USE_THREADS))
+#if !defined(__GNUC__) && (defined(CRIPPLED_CC) || defined(USE_THREADS) || defined(PERL_OBJECT))
VIRTUAL SV* newRV_noinc _((SV *));
#endif
#ifdef LEAKTEST
VIRTUAL void save_delete _((HV* hv, char* key, I32 klen));
#ifndef titan /* TitanOS cc can't handle this */
#ifdef PERL_OBJECT
-VIRTUAL void save_destructor _((void (*f)(void*, void*), void* p));
+typedef void (CPerlObj::*DESTRUCTORFUNC) _((void*));
+VIRTUAL void save_destructor _((DESTRUCTORFUNC f, void* p));
#else
void save_destructor _((void (*f)(void*), void* p));
#endif
typedef void (CPerlObj::*SVFUNC) _((SV*));
void visit _((SVFUNC f));
+typedef I32 (CPerlObj::*SVCOMPARE) _((SV*, SV*));
+void qsortsv _((SV ** array, size_t num_elts, SVCOMPARE f));
+I32 sortcv _((SV *a, SV *b));
void save_magic _((MGS *mgs, SV *sv));
int magic_methpack _((SV *sv, MAGIC *mg, char *meth));
+int magic_methcall _((MAGIC *mg, char *meth, I32 flags, int n, SV *val));
OP * doform _((CV *cv, GV *gv, OP *retop));
void doencodes _((SV* sv, char* s, I32 len));
SV* refto _((SV* sv));
void dump _((char *pat,...));
#ifdef WIN32
int do_aspawn _((void *vreally, void **vmark, void **vsp));
+void BootDynaLoader(void);
#endif
#ifdef DEBUGGING
void restore_magic _((void *p));
void restore_rsfp _((void *f));
void yydestruct _((void *ptr));
-int sortcv _((const void *, const void *));
-int sortcmp _((const void *, const void *));
-int sortcmp_locale _((const void *, const void *));
VIRTUAL int fprintf _((PerlIO *, const char *, ...));
#ifdef WIN32
}
if (OP(scan) == SUSPEND) {
locinput = reginput;
- nextchar = UCHARAT(locinput);
+ nextchr = UCHARAT(locinput);
}
/* FALL THROUGH. */
case LONGJMP:
void
#ifdef PERL_OBJECT
-save_destructor(void (*f) (void*, void*), void* p)
+save_destructor(DESTRUCTORFUNC f, void* p)
#else
save_destructor(void (*f) (void *), void *p)
#endif
break;
case SAVEt_DESTRUCTOR:
ptr = SSPOPPTR;
- (*SSPOPDPTR)(THIS_ ptr);
+ (CALLDESTRUCTOR)(ptr);
break;
case SAVEt_REGCONTEXT:
{
#define SAVEDELETE(h,k,l) \
save_delete(SOFT_CAST(HV*)(h), SOFT_CAST(char*)(k), (I32)(l))
#ifdef PERL_OBJECT
+#define CALLDESTRUCTOR this->*SSPOPDPTR
#define SAVEDESTRUCTOR(f,p) \
- save_destructor(SOFT_CAST(void(*)_((void*, void*)))(f),SOFT_CAST(void*)(p))
+ save_destructor((DESTRUCTORFUNC)(f),SOFT_CAST(void*)(p))
#else
+#define CALLDESTRUCTOR *SSPOPDPTR
#define SAVEDESTRUCTOR(f,p) \
save_destructor(SOFT_CAST(void(*)_((void*)))(f),SOFT_CAST(void*)(p))
#endif
if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
if (how == 't')
- mg->mg_length |= 1;
+ mg->mg_len |= 1;
return;
}
}
mg->mg_flags |= MGf_REFCOUNTED;
}
mg->mg_type = how;
- mg->mg_length = namlen;
+ mg->mg_len = namlen;
if (name)
if (namlen >= 0)
mg->mg_ptr = savepvn(name, namlen);
break;
case 't':
mg->mg_virtual = &vtbl_taint;
- mg->mg_length = 1;
+ mg->mg_len = 1;
break;
case 'U':
mg->mg_virtual = &vtbl_uvar;
if (vtbl && (vtbl->svt_free != NULL))
(VTBL->svt_free)(sv, mg);
if (mg->mg_ptr && mg->mg_type != 'g')
- if (mg->mg_length >= 0)
+ if (mg->mg_len >= 0)
Safefree(mg->mg_ptr);
- else if (mg->mg_length == HEf_SVKEY)
+ else if (mg->mg_len == HEf_SVKEY)
SvREFCNT_dec((SV*)mg->mg_ptr);
if (mg->mg_flags & MGf_REFCOUNTED)
SvREFCNT_dec(mg->mg_obj);
return 0;
if (SvGMAGICAL(sv))
- len = mg_len(sv);
+ len = mg_length(sv);
else
junk = SvPV(sv, len);
return len;
assert(mg);
}
mg->mg_ptr = xf;
- mg->mg_length = xlen;
+ mg->mg_len = xlen;
}
else {
if (mg) {
mg->mg_ptr = NULL;
- mg->mg_length = -1;
+ mg->mg_len = -1;
}
}
}
if (mg && mg->mg_ptr) {
- *nxp = mg->mg_length;
+ *nxp = mg->mg_len;
return mg->mg_ptr + sizeof(collation_ix);
}
else {
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
MAGIC *mg = mg_find(sv, 't');
if (mg)
- mg->mg_length &= ~1;
+ mg->mg_len &= ~1;
}
}
{
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
MAGIC *mg = mg_find(sv, 't');
- if (mg && ((mg->mg_length & 1) || (mg->mg_length & 2) && mg->mg_obj == sv))
+ if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
return TRUE;
}
return FALSE;
/* grandfather return to old style */
#define OLDLOP(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)LSTOP)
-#ifdef PERL_OBJECT
-static void RestoreRsfp(void *pPerl, void *ptr)
-{
- ((CPerlObj*)pPerl)->restore_rsfp(ptr);
-}
-#define RESTORERSFP RestoreRsfp
-#else
-#define RESTORERSFP restore_rsfp
-#endif
-
STATIC int
ao(int toketype)
{
SAVESPTR(linestr);
SAVEPPTR(lex_brackstack);
SAVEPPTR(lex_casestack);
- SAVEDESTRUCTOR(RESTORERSFP, rsfp);
+ SAVEDESTRUCTOR(restore_rsfp, rsfp);
lex_state = LEX_NORMAL;
lex_defer = 0;
}
+#ifdef PERL_OBJECT
+#define NO_XSLOCKS
+#endif /* PERL_OBJECT */
+
#include "XSUB.h"
static
sv_magic(sv, Nullsv, 'm', 0, 0);
mg = SvMAGIC(sv);
mg->mg_ptr = (char *)cp;
- mg->mg_length = sizeof(cp);
+ mg->mg_len = sizeof(cp);
MUTEX_UNLOCK(&sv_mutex);
DEBUG_L(WITH_THR(PerlIO_printf(PerlIO_stderr(),
"%p: condpair_magic %p\n", thr, sv));)
#include "EXTERN.h"
#include "perl.h"
+
+#ifdef PERL_OBJECT
+#define NO_XSLOCKS
+#endif /* PERL_OBJECT */
+
#include "XSUB.h"
#include "dlutils.c" /* SaveError() etc */
static void
-dl_private_init(void)
+dl_private_init(CPERLarg)
{
- (void)dl_generic_private_init();
+ (void)dl_generic_private_init(THIS);
}
+#ifdef PERL_OBJECT
+#define dl_static_linked(x) 0
+#else
static int
dl_static_linked(char *filename)
{
};
return 0;
}
+#endif
MODULE = DynaLoader PACKAGE = DynaLoader
int CPerlLIO::FStat(int fd, struct stat *sbufptr, int &err)
{
- int ret = fstat(fd, sbufptr);
- if(errno)
- err = errno;
- return ret;
+ CALLFUNCERR(fstat(fd, sbufptr))
}
int CPerlLIO::IOCtl(int i, unsigned int u, char *data, int &err)
int CPerlLIO::Lstat(const char *path, struct stat *sbufptr, int &err)
{
- return stat(path, sbufptr);
+ return STat(path, sbufptr, err);
}
char *CPerlLIO::Mktemp(char *Template, int &err)
int CPerlLIO::Open(const char *filename, int oflag, int &err)
{
- CALLFUNCERR(open(filename, oflag))
+ int ret;
+ if(stricmp(filename, "/dev/null") == 0)
+ ret = open("NUL", oflag);
+ else
+ ret = open(filename, oflag);
+
+ if(errno)
+ err = errno;
+ return ret;
}
int CPerlLIO::Open(const char *filename, int oflag, int pmode, int &err)
{
- CALLFUNCERR(open(filename, oflag, pmode))
+ int ret;
+ if(stricmp(filename, "/dev/null") == 0)
+ ret = open("NUL", oflag, pmode);
+ else
+ ret = open(filename, oflag, pmode);
+
+ if(errno)
+ err = errno;
+ return ret;
}
int CPerlLIO::Read(int fd, void *buffer, unsigned int cnt, int &err)
int CPerlLIO::STat(const char *path, struct stat *sbufptr, int &err)
{
- return stat(path, sbufptr);
+ char t[MAX_PATH];
+ const char *p = path;
+ int l = strlen(path);
+ int res;
+
+ if (l > 1) {
+ switch(path[l - 1]) {
+ case '\\':
+ case '/':
+ if (path[l - 2] != ':') {
+ strncpy(t, path, l - 1);
+ t[l - 1] = 0;
+ p = t;
+ };
+ }
+ }
+ res = stat(path, sbufptr);
+#ifdef __BORLANDC__
+ if (res == 0) {
+ if (S_ISDIR(buffer->st_mode))
+ buffer->st_mode |= S_IWRITE | S_IEXEC;
+ else if (S_ISREG(buffer->st_mode)) {
+ if (l >= 4 && path[l-4] == '.') {
+ const char *e = path + l - 3;
+ if (strnicmp(e,"exe",3)
+ && strnicmp(e,"bat",3)
+ && strnicmp(e,"com",3)
+ && (IsWin95() || strnicmp(e,"cmd",3)))
+ buffer->st_mode &= ~S_IEXEC;
+ else
+ buffer->st_mode |= S_IEXEC;
+ }
+ else
+ buffer->st_mode &= ~S_IEXEC;
+ }
+ }
+#endif
+ return res;
}
char *CPerlLIO::Tmpnam(char *string, int &err)
pPerl = NULL;
pSock = NULL;
w32_platform = -1;
+ ZeroMemory(bSocketTable, sizeof(bSocketTable));
};
virtual PerlIO* Stdin(void);
virtual PerlIO* Stdout(void);
virtual int Ungetc(PerlIO*,int, int &err);
virtual int Fileno(PerlIO*, int &err);
virtual PerlIO* Fdopen(int, const char *, int &err);
+ virtual PerlIO* Reopen(const char*, const char*, PerlIO*, int &err);
virtual SSize_t Read(PerlIO*,void *,Size_t, int &err);
virtual SSize_t Write(PerlIO*,const void *,Size_t, int &err);
+ virtual void SetBuf(PerlIO *, char*, int &err);
+ virtual int SetVBuf(PerlIO *, char*, int, Size_t, int &err);
virtual void SetCnt(PerlIO *, int, int &err);
virtual void SetPtrCnt(PerlIO *, char *, int, int& err);
virtual void Setlinebuf(PerlIO*, int &err);
PerlIO* ret = NULL;
if(*path != '\0')
{
- ret = (PerlIO*)fopen(path, mode);
+ if(stricmp(path, "/dev/null") == 0)
+ ret = (PerlIO*)fopen("NUL", mode);
+ else
+ ret = (PerlIO*)fopen(path, mode);
+
if(errno)
err = errno;
}
return ret;
}
+PerlIO* CPerlStdIO::Reopen(const char* filename, const char* mode, PerlIO* pf, int &err)
+{
+ PerlIO* ret = (PerlIO*)freopen(filename, mode, (FILE*)pf);
+ if(errno)
+ err = errno;
+ return ret;
+}
+
SSize_t CPerlStdIO::Read(PerlIO* pf, void * buffer, Size_t count, int &err)
{
size_t ret = fread(buffer, 1, count, (FILE*)pf);
return ret;
}
-void CPerlStdIO::Setlinebuf(PerlIO*, int &err)
+void CPerlStdIO::Setlinebuf(PerlIO*pf, int &err)
{
- croak("setlinebuf not implemented!\n");
+ setvbuf((FILE*)pf, NULL, _IOLBF, 0);
}
int CPerlStdIO::Printf(PerlIO* pf, int &err, const char *format, ...)
return ((FILE*)pf)->_ptr;
}
+void CPerlStdIO::SetBuf(PerlIO *pf, char* buffer, int &err)
+{
+ setbuf((FILE*)pf, buffer);
+}
+
+int CPerlStdIO::SetVBuf(PerlIO *pf, char* buffer, int type, Size_t size, int &err)
+{
+ return setvbuf((FILE*)pf, buffer, type, size);
+}
+
void CPerlStdIO::SetCnt(PerlIO *pf, int n, int &err)
{
((FILE*)pf)->_cnt = n;
-LIBRARY Perl500
+LIBRARY PerlCore
DESCRIPTION 'Perl interpreter'
EXPORTS
perl_alloc
#include "EXTERN.h"
#include "perl.h"
+#define NO_XSLOCKS
#include "XSUB.H"
+#undef errno
+#if defined(_MT)
+_CRTIMP int * __cdecl _errno(void);
+#define errno (*_errno())
+#else
+_CRTIMP extern int errno;
+#endif
#include <ipdir.h>
#include <ipenv.h>
projects / p5sagit/p5-mst-13.2.git / commitdiff