This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[asperl] added AS patch#3
authorDouglas Lankshear <doug@lankshear.net>
Sun, 1 Feb 1998 09:18:13 +0000 (01:18 -0800)
committerGurusamy Sarathy <gsar@cpan.org>
Sun, 1 Feb 1998 22:20:20 +0000 (22:20 +0000)
Message-Id: <01BD2EF2.53433A40.dougl@ActiveState.com>
To:      "'Gurusamy Sarathy'" <gsar@umich.edu>

Here's an additional diff against //depot/asperl

The field name mg_length was changed back to mg_len
The function name mg_len was change to mg_length

The need for sort_mutex removed thanks to the code derived
from Tom Horsley's work.

 -- Doug

p4raw-id: //depot/asperl@451

32 files changed:
ObjXSub.h
XSLock.h [new file with mode: 0644]
XSUB.h
av.c
embedvar.h
ext/DynaLoader/dlutils.c
globals.c
ipstdio.h
mg.c
mg.h
objpp.h
perl.c
perl.h
perlio.h
perlvars.h
perly.c
pp.c
pp_ctl.c
pp_hot.c
proto.h
regexec.c
scope.c
scope.h
sv.c
toke.c
universal.c
util.c
win32/dl_win32.xs
win32/iplio.c
win32/ipstdio.c
win32/perlobj.def
win32/runperl.c

index 7f2acf3..eadd922 100644 (file)
--- a/ObjXSub.h
+++ b/ObjXSub.h
 #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
diff --git a/XSLock.h b/XSLock.h
new file mode 100644 (file)
index 0000000..652f492
--- /dev/null
+++ b/XSLock.h
@@ -0,0 +1,35 @@
+#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
diff --git a/XSUB.h b/XSUB.h
index 10aed07..73c76b1 100644 (file)
--- a/XSUB.h
+++ b/XSUB.h
@@ -76,4 +76,9 @@
 
 #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 */
diff --git a/av.c b/av.c
index 20c77d8..87e86a5 100644 (file)
--- a/av.c
+++ b/av.c
@@ -367,7 +367,13 @@ av_undef(register AV *av)
            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;
index 5d3e1d1..7f3dce0 100644 (file)
 #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
index 422b3d1..f7c630a 100644 (file)
@@ -26,7 +26,7 @@ static int dl_debug = 0;      /* value copied from $DynaLoader::dl_error */
 
 
 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
@@ -45,7 +45,7 @@ dl_generic_private_init(void) /* called by dl_*.xs dl_private_init() */
 
 /* 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;
index a566925..9f77299 100644 (file)
--- a/globals.c
+++ b/globals.c
@@ -1435,14 +1435,11 @@ CPerlObj::Init(void)
        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;
@@ -1497,6 +1494,15 @@ do_aspawn(void *vreally, void **vmark, void **vsp)
        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 */
index bb6c14f..7ae28ce 100644 (file)
--- a/ipstdio.h
+++ b/ipstdio.h
@@ -34,8 +34,11 @@ public:
        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;
diff --git a/mg.c b/mg.c
index 93dd8e5..a487674 100644 (file)
--- a/mg.c
+++ b/mg.c
  */
 
 #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
@@ -52,8 +42,6 @@ struct magic_state {
 typedef struct magic_state MGS;
 
 static void restore_magic _((void *p));
-#define UNWINDHANDLER   unwind_handler_stack
-#define RESTOREMAGIC   restore_magic
 #define VTBL                   *vtbl
 
 #endif
@@ -65,7 +53,7 @@ save_magic(MGS *mgs, SV *sv)
 
     mgs->mgs_sv = sv;
     mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
-    SAVEDESTRUCTOR(RESTOREMAGIC, mgs);
+    SAVEDESTRUCTOR(restore_magic, mgs);
 
     SvMAGICAL_off(sv);
     SvREADONLY_off(sv);
@@ -166,7 +154,7 @@ mg_set(SV *sv)
 }
 
 U32
-mg_len(SV *sv)
+mg_length(SV *sv)
 {
     MAGIC* mg;
     char *junk;
@@ -198,11 +186,11 @@ mg_size(SV *sv)
     
     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;
        }
@@ -278,9 +266,9 @@ mg_free(SV *sv)
        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);
@@ -984,7 +972,7 @@ magic_setnkeys(SV *sv, MAGIC *mg)
     return 0;
 }          
 
-static int
+STATIC int
 magic_methcall(MAGIC *mg, char *meth, I32 flags, int n, SV *val)
 {
     dSP;
@@ -994,13 +982,13 @@ magic_methcall(MAGIC *mg, char *meth, I32 flags, int n, SV *val)
     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) {
@@ -1155,9 +1143,9 @@ magic_getpos(SV *sv, MAGIC *mg)
     
     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;
        }
     }
@@ -1183,7 +1171,7 @@ magic_setpos(SV *sv, MAGIC *mg)
        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);
@@ -1196,7 +1184,7 @@ magic_setpos(SV *sv, MAGIC *mg)
     }
     else if (pos > len)
        pos = len;
-    mg->mg_length = pos;
+    mg->mg_len = pos;
     mg->mg_flags &= ~MGf_MINMATCH;
 
     return 0;
@@ -1248,8 +1236,8 @@ int
 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;
 }
 
@@ -1259,14 +1247,14 @@ magic_settaint(SV *sv, MAGIC *mg)
     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;
 }
 
@@ -1366,7 +1354,7 @@ vivify_defelem(SV *sv)
 int
 magic_setmglob(SV *sv, MAGIC *mg)
 {
-    mg->mg_length = -1;
+    mg->mg_len = -1;
     SvSCREAM_off(sv);
     return 0;
 }
@@ -1416,7 +1404,7 @@ magic_setcollxfrm(SV *sv, MAGIC *mg)
     if (mg->mg_ptr) {
        Safefree(mg->mg_ptr);
        mg->mg_ptr = NULL;
-       mg->mg_length = -1;
+       mg->mg_len = -1;
     }
     return 0;
 }
@@ -1866,7 +1854,7 @@ sighandler(int sig)
     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. */
diff --git a/mg.h b/mg.h
index 2610d1a..1490470 100644 (file)
--- a/mg.h
+++ b/mg.h
@@ -23,7 +23,7 @@ struct magic {
     U8         mg_flags;
     SV*                mg_obj;
     char*      mg_ptr;
-    I32                mg_length;
+    I32                mg_len;
 };
 
 #define MGf_TAINTEDDIR 1
@@ -36,6 +36,6 @@ struct magic {
 #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)
diff --git a/objpp.h b/objpp.h
index 7a9cd2d..f1d8c06 100644 (file)
--- a/objpp.h
+++ b/objpp.h
 #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
diff --git a/perl.c b/perl.c
index 490b8c6..8f4525e 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -164,10 +164,6 @@ perl_construct(register PerlInterpreter *sv_interp)
        MUTEX_INIT(&threads_mutex);
        COND_INIT(&nthreads_cond);
 
-#ifdef PERL_OBJECT
-       MUTEX_INIT(&sort_mutex);
-#endif
-       
        thr = init_main_thread();
 #endif /* USE_THREADS */
 
@@ -561,9 +557,6 @@ perl_destruct(register PerlInterpreter *sv_interp)
     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);
@@ -596,6 +589,7 @@ perl_free(PerlInterpreter *sv_interp)
 #endif
 {
 #ifdef PERL_OBJECT
+       Safefree(this);
 #else
     if (!(curinterp = sv_interp))
        return;
@@ -946,6 +940,9 @@ print \"  \\@INC:\\n    @INC\\n\";");
     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)
diff --git a/perl.h b/perl.h
index c14a1d0..4ea9b96 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -43,7 +43,7 @@ class CPerlObj;
 #define CPERLscope(x) x
 #define CPERLproto
 #define CPERLproto_ 
-#define CPERLarg
+#define CPERLarg void
 #define CPERLarg_
 #define THIS
 #define THIS_
@@ -1101,11 +1101,7 @@ union any {
     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
index 892d803..48bb386 100644 (file)
--- a/perlio.h
+++ b/perlio.h
@@ -48,8 +48,11 @@ extern void PerlIO_init _((void));
 #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())
index ab33549..1faa80c 100644 (file)
@@ -25,8 +25,6 @@ PERLVAR(Gcurthr,      struct perl_thread *)   /* Currently executing (fake) thread */
 #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
diff --git a/perly.c b/perly.c
index e55dcff..2cd4f05 100644 (file)
--- a/perly.c
+++ b/perly.c
@@ -1326,16 +1326,6 @@ yydestruct(void *ptr)
     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)
 {
@@ -1354,7 +1344,7 @@ 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;
diff --git a/pp.c b/pp.c
index 272c208..aaeca3f 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -325,8 +325,8 @@ PP(pp_pos)
 
        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;
            }
        }
index 60e8825..094631b 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -637,15 +637,6 @@ PP(pp_mapwhile)
     }
 }
 
-
-#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;
@@ -751,15 +742,7 @@ PP(pp_sort)
                    (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);
@@ -770,18 +753,8 @@ PP(pp_sort)
     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;
@@ -3017,8 +2990,13 @@ struct partition_stack_entry {
 
 /* 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++;
@@ -3099,10 +3077,14 @@ doqsort_all_asserts(
 /* ****************************************************************** 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;
 
index 10fecf7..176dc2c 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -806,8 +806,8 @@ PP(pp_match)
        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;
            }
@@ -929,7 +929,7 @@ play_it_again:
                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
@@ -976,7 +976,7 @@ ret_no:
        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);
diff --git a/proto.h b/proto.h
index 8131fb6..c14c3e8 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -278,7 +278,7 @@ VIRTUAL int mg_copy _((SV* , SV* , char* , I32));
 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));
@@ -344,7 +344,7 @@ VIRTUAL OP* newLISTOP _((I32 type, I32 flags, OP* first, OP* last));
 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
@@ -465,7 +465,8 @@ VIRTUAL void        save_clearsv _((SV** svp));
 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
@@ -670,8 +671,12 @@ void not_a_number _((SV *sv));
 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));
@@ -795,6 +800,7 @@ char * regcppop _((void));
 void dump _((char *pat,...));
 #ifdef WIN32
 int do_aspawn _((void *vreally, void **vmark, void **vsp));
+void BootDynaLoader(void);
 #endif
 
 #ifdef DEBUGGING
@@ -1186,9 +1192,6 @@ void unwind_handler_stack _((void *p));
 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
index a103e3e..32c9c75 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -1580,7 +1580,7 @@ regmatch(regnode *prog)
            }
            if (OP(scan) == SUSPEND) {
                locinput = reginput;
-               nextchar = UCHARAT(locinput);
+               nextchr = UCHARAT(locinput);
            }
            /* FALL THROUGH. */
        case LONGJMP:
diff --git a/scope.c b/scope.c
index 0705922..52d5605 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -452,7 +452,7 @@ save_list(register SV **sarg, I32 maxsarg)
 
 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
@@ -691,7 +691,7 @@ leave_scope(I32 base)
            break;
        case SAVEt_DESTRUCTOR:
            ptr = SSPOPPTR;
-           (*SSPOPDPTR)(THIS_ ptr);
+           (CALLDESTRUCTOR)(ptr);
            break;
        case SAVEt_REGCONTEXT:
            {
diff --git a/scope.h b/scope.h
index 87d66bb..318f69e 100644 (file)
--- a/scope.h
+++ b/scope.h
 #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
diff --git a/sv.c b/sv.c
index f8c14d0..44f4417 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -2353,7 +2353,7 @@ sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen)
     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;
        }
     }
@@ -2373,7 +2373,7 @@ sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen)
        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);
@@ -2454,7 +2454,7 @@ sv_magic(register SV *sv, SV *obj, int how, char *name, I32 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;
@@ -2506,9 +2506,9 @@ sv_unmagic(SV *sv, int type)
            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);
@@ -2833,7 +2833,7 @@ sv_len(register SV *sv)
        return 0;
 
     if (SvGMAGICAL(sv))
-       len = mg_len(sv);
+       len = mg_length(sv);
     else
        junk = SvPV(sv, len);
     return len;
@@ -2971,17 +2971,17 @@ sv_collxfrm(SV *sv, STRLEN *nxp)
                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 {
@@ -4016,7 +4016,7 @@ sv_untaint(SV *sv)
     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
        MAGIC *mg = mg_find(sv, 't');
        if (mg)
-           mg->mg_length &= ~1;
+           mg->mg_len &= ~1;
     }
 }
 
@@ -4025,7 +4025,7 @@ sv_tainted(SV *sv)
 {
     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;
diff --git a/toke.c b/toke.c
index efc9b35..b534fd7 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -145,16 +145,6 @@ static struct {
 /* 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)
 {
@@ -268,7 +258,7 @@ lex_start(SV *line)
     SAVESPTR(linestr);
     SAVEPPTR(lex_brackstack);
     SAVEPPTR(lex_casestack);
-    SAVEDESTRUCTOR(RESTORERSFP, rsfp);
+    SAVEDESTRUCTOR(restore_rsfp, rsfp);
 
     lex_state = LEX_NORMAL;
     lex_defer = 0;
index 18989aa..72da1e4 100644 (file)
@@ -100,6 +100,10 @@ sv_derived_from(SV *sv, char *name)
  
 }
 
+#ifdef PERL_OBJECT
+#define NO_XSLOCKS
+#endif  /* PERL_OBJECT */
+
 #include "XSUB.h"
 
 static
diff --git a/util.c b/util.c
index 271629d..cd61fa1 100644 (file)
--- a/util.c
+++ b/util.c
@@ -2458,7 +2458,7 @@ condpair_magic(SV *sv)
            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));)
index 13d9721..f25a30f 100644 (file)
@@ -26,16 +26,24 @@ calls.
 
 #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)
 {
@@ -45,6 +53,7 @@ dl_static_linked(char *filename)
     };
     return 0;
 }
+#endif
 
 MODULE = DynaLoader    PACKAGE = DynaLoader
 
index 3522284..2969126 100644 (file)
@@ -171,10 +171,7 @@ int CPerlLIO::Flock(int fd, int oper, int &err)
 
 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)
@@ -194,7 +191,7 @@ long CPerlLIO::Lseek(int fd, long offset, int origin, 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)
@@ -204,12 +201,28 @@ 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)
@@ -276,7 +289,44 @@ int CPerlLIO::Setmode(int fd, int mode, 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)
index 7d37373..d95c692 100644 (file)
@@ -16,6 +16,7 @@ public:
                pPerl = NULL;
                pSock = NULL;
                w32_platform = -1;
+               ZeroMemory(bSocketTable, sizeof(bSocketTable));
        };
        virtual PerlIO* Stdin(void);
        virtual PerlIO* Stdout(void);
@@ -36,8 +37,11 @@ public:
        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);
@@ -218,7 +222,11 @@ PerlIO* CPerlStdIO::Open(const char *path, const char *mode, 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;
        }
@@ -324,6 +332,14 @@ PerlIO* CPerlStdIO::Fdopen(int fh, const char *mode, int &err)
        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);
@@ -340,9 +356,9 @@ SSize_t CPerlStdIO::Write(PerlIO* pf, const void * buffer, Size_t count, int &er
        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, ...)
@@ -425,6 +441,16 @@ char* CPerlStdIO::GetPtr(PerlIO *pf, int &err)
        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;
index 6b0f65d..28816cd 100644 (file)
@@ -1,4 +1,4 @@
-LIBRARY Perl500
+LIBRARY PerlCore
 DESCRIPTION 'Perl interpreter'
 EXPORTS
        perl_alloc
index 76f9ea0..5cacb83 100644 (file)
@@ -4,7 +4,15 @@
 #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>