The exact error message is system-dependent.
[p5sagit/p5-mst-13.2.git] / perl.c
diff --git a/perl.c b/perl.c
index 51cb927..e19ea45 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -25,7 +25,7 @@
 char *getenv (char *); /* Usually in <stdlib.h> */
 #endif
 
-static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
+static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
 
 #ifdef IAMSUID
 #ifndef DOSUID
@@ -39,14 +39,6 @@ static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
 #endif
 #endif
 
-#ifdef PERL_OBJECT
-#define perl_construct Perl_construct
-#define perl_parse     Perl_parse
-#define perl_run       Perl_run
-#define perl_destruct  Perl_destruct
-#define perl_free      Perl_free
-#endif
-
 #if defined(USE_5005THREADS)
 #  define INIT_TLS_AND_INTERP \
     STMT_START {                               \
@@ -91,11 +83,6 @@ perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
                 struct IPerlProc* ipP)
 {
     PerlInterpreter *my_perl;
-#ifdef PERL_OBJECT
-    my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd,
-                                                 ipLIO, ipD, ipS, ipP);
-    INIT_TLS_AND_INTERP;
-#else
     /* New() needs interpreter, so call malloc() instead */
     my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
     INIT_TLS_AND_INTERP;
@@ -109,7 +96,6 @@ perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
     PL_Dir = ipD;
     PL_Sock = ipS;
     PL_Proc = ipP;
-#endif
 
     return my_perl;
 }
@@ -212,12 +198,7 @@ perl_construct(pTHXx)
            SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
        }
 
-#ifdef PERL_OBJECT
-       /* TODO: */
-       /* PL_sighandlerp = sighandler; */
-#else
        PL_sighandlerp = Perl_sighandler;
-#endif
        PL_pidstatus = newHV();
 
 #ifdef MSDOS
@@ -306,7 +287,7 @@ Shuts down a Perl interpreter.  See L<perlembed>.
 int
 perl_destruct(pTHXx)
 {
-    int destruct_level;  /* 0=none, 1=full, 2=full with checks */
+    volatile int destruct_level;  /* 0=none, 1=full, 2=full with checks */
     HV *hv;
 #ifdef USE_5005THREADS
     Thread t;
@@ -450,7 +431,7 @@ perl_destruct(pTHXx)
 
     /* call exit list functions */
     while (PL_exitlistlen-- > 0)
-       PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
+       PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
 
     Safefree(PL_exitlist);
 
@@ -496,7 +477,10 @@ perl_destruct(pTHXx)
                  * flag is set in regexec.c:S_regtry
                  */
                 SvFLAGS(resv) &= ~SVf_BREAK;
-            }
+            } 
+           else if(SvREPADTMP(resv)) {
+             SvREPADTMP_off(resv);
+           }
             else {
                 ReREFCNT_dec(re);
             }
@@ -871,34 +855,30 @@ Releases a Perl interpreter.  See L<perlembed>.
 void
 perl_free(pTHXx)
 {
-#if defined(PERL_OBJECT)
-    PerlMem_free(this);
-#else
-#  if defined(WIN32) || defined(NETWARE)
+#if defined(WIN32) || defined(NETWARE)
 #  if defined(PERL_IMPLICIT_SYS)
-    #ifdef NETWARE
-               void *host = nw_internal_host;
-       #else
-               void *host = w32_internal_host;
-       #endif
-       #ifndef NETWARE
-       if (PerlProc_lasthost()) {
+#    ifdef NETWARE
+    void *host = nw_internal_host;
+#    else
+    void *host = w32_internal_host;
+#    endif
+#    ifndef NETWARE
+    if (PerlProc_lasthost()) {
        PerlIO_cleanup();
-       }
-       #endif
-    PerlMem_free(aTHXx);
-       #ifdef NETWARE
-               nw5_delete_internal_host(host);
-       #else
-               win32_delete_internal_host(host);
-       #endif
-#else
-    PerlIO_cleanup();
+    }
+#    endif
     PerlMem_free(aTHXx);
-#endif
+#    ifdef NETWARE
+    nw5_delete_internal_host(host);
+#    else
+    win32_delete_internal_host(host);
+#    endif
 #  else
+    PerlIO_cleanup();
     PerlMem_free(aTHXx);
 #  endif
+#else
+    PerlMem_free(aTHXx);
 #endif
 }
 
@@ -1192,9 +1172,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 #  ifdef USE_SOCKS
                sv_catpv(PL_Sv," USE_SOCKS");
 #  endif
-#  ifdef PERL_OBJECT
-               sv_catpv(PL_Sv," PERL_OBJECT");
-#  endif
 #  ifdef PERL_IMPLICIT_CONTEXT
                sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
 #  endif
@@ -1395,7 +1372,7 @@ print \"  \\@INC:\\n    @INC\\n\";");
 #endif
 
     if (xsinit)
-       (*xsinit)(aTHXo);       /* in case linked C routines want magical variables */
+       (*xsinit)(aTHX);        /* in case linked C routines want magical variables */
 #ifndef PERL_MICRO
 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
     init_os_extras();
@@ -2167,8 +2144,9 @@ Perl_moreswitches(pTHX_ char *s)
     switch (*s) {
     case '0':
     {
-       numlen = 0;                     /* disallow underscores */
-       rschar = (U32)scan_oct(s, 4, &numlen);
+        I32 flags = 0;
+       numlen = 4;
+       rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
        SvREFCNT_dec(PL_nrs);
        if (rschar & ~((U8)~0))
            PL_nrs = &PL_sv_undef;
@@ -2299,9 +2277,10 @@ Perl_moreswitches(pTHX_ char *s)
            PL_ors_sv = Nullsv;
        }
        if (isDIGIT(*s)) {
+            I32 flags = 0;
            PL_ors_sv = newSVpvn("\n",1);
-           numlen = 0;                 /* disallow underscores */
-           *SvPVX(PL_ors_sv) = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
+           numlen = 3 + (*s == '0');
+           *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
            s += numlen;
        }
        else {
@@ -2558,77 +2537,42 @@ STATIC void
 S_init_interp(pTHX)
 {
 
-#ifdef PERL_OBJECT             /* XXX kludge */
-#define I_REINIT \
-  STMT_START {                         \
-    PL_chopset         = " \n-";       \
-    PL_copline         = NOLINE;       \
-    PL_curcop          = &PL_compiling;\
-    PL_curcopdb                = NULL;         \
-    PL_dbargs          = 0;            \
-    PL_dumpindent      = 4;            \
-    PL_laststatval     = -1;           \
-    PL_laststype       = OP_STAT;      \
-    PL_maxscream       = -1;           \
-    PL_maxsysfd                = MAXSYSFD;     \
-    PL_statname                = Nullsv;       \
-    PL_tmps_floor      = -1;           \
-    PL_tmps_ix         = -1;           \
-    PL_op_mask         = NULL;         \
-    PL_laststatval     = -1;           \
-    PL_laststype       = OP_STAT;      \
-    PL_mess_sv         = Nullsv;       \
-    PL_splitstr                = " ";          \
-    PL_generation      = 100;          \
-    PL_exitlist                = NULL;         \
-    PL_exitlistlen     = 0;            \
-    PL_regindent       = 0;            \
-    PL_in_clean_objs   = FALSE;        \
-    PL_in_clean_all    = FALSE;        \
-    PL_profiledata     = NULL;         \
-    PL_rsfp            = Nullfp;       \
-    PL_rsfp_filters    = Nullav;       \
-    PL_dirty           = FALSE;        \
-  } STMT_END
-    I_REINIT;
-#else
-#  ifdef MULTIPLICITY
-#    define PERLVAR(var,type)
-#    define PERLVARA(var,n,type)
-#    if defined(PERL_IMPLICIT_CONTEXT)
-#      if defined(USE_5005THREADS)
-#        define PERLVARI(var,type,init)                PERL_GET_INTERP->var = init;
-#        define PERLVARIC(var,type,init)       PERL_GET_INTERP->var = init;
-#      else /* !USE_5005THREADS */
-#        define PERLVARI(var,type,init)                aTHX->var = init;
-#        define PERLVARIC(var,type,init)       aTHX->var = init;
-#      endif /* USE_5005THREADS */
-#    else
-#      define PERLVARI(var,type,init)  PERL_GET_INTERP->var = init;
+#ifdef MULTIPLICITY
+#  define PERLVAR(var,type)
+#  define PERLVARA(var,n,type)
+#  if defined(PERL_IMPLICIT_CONTEXT)
+#    if defined(USE_5005THREADS)
+#      define PERLVARI(var,type,init)          PERL_GET_INTERP->var = init;
 #      define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
-#    endif
-#    include "intrpvar.h"
-#    ifndef USE_5005THREADS
-#      include "thrdvar.h"
-#    endif
-#    undef PERLVAR
-#    undef PERLVARA
-#    undef PERLVARI
-#    undef PERLVARIC
+#    else /* !USE_5005THREADS */
+#      define PERLVARI(var,type,init)          aTHX->var = init;
+#      define PERLVARIC(var,type,init) aTHX->var = init;
+#    endif /* USE_5005THREADS */
 #  else
-#    define PERLVAR(var,type)
-#    define PERLVARA(var,n,type)
-#    define PERLVARI(var,type,init)    PL_##var = init;
-#    define PERLVARIC(var,type,init)   PL_##var = init;
-#    include "intrpvar.h"
-#    ifndef USE_5005THREADS
-#      include "thrdvar.h"
-#    endif
-#    undef PERLVAR
-#    undef PERLVARA
-#    undef PERLVARI
-#    undef PERLVARIC
+#    define PERLVARI(var,type,init)    PERL_GET_INTERP->var = init;
+#    define PERLVARIC(var,type,init)   PERL_GET_INTERP->var = init;
+#  endif
+#  include "intrpvar.h"
+#  ifndef USE_5005THREADS
+#    include "thrdvar.h"
+#  endif
+#  undef PERLVAR
+#  undef PERLVARA
+#  undef PERLVARI
+#  undef PERLVARIC
+#else
+#  define PERLVAR(var,type)
+#  define PERLVARA(var,n,type)
+#  define PERLVARI(var,type,init)      PL_##var = init;
+#  define PERLVARIC(var,type,init)     PL_##var = init;
+#  include "intrpvar.h"
+#  ifndef USE_5005THREADS
+#    include "thrdvar.h"
 #  endif
+#  undef PERLVAR
+#  undef PERLVARA
+#  undef PERLVARI
+#  undef PERLVARIC
 #endif
 
 }
@@ -3355,16 +3299,10 @@ S_nuke_stacks(pTHX)
     Safefree(PL_retstack);
 }
 
-#ifndef PERL_OBJECT
-static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
-#endif
-
 STATIC void
 S_init_lexer(pTHX)
 {
-#ifdef PERL_OBJECT
-       PerlIO *tmpfp;
-#endif
+    PerlIO *tmpfp;
     tmpfp = PL_rsfp;
     PL_rsfp = Nullfp;
     lex_start(PL_linestr);
@@ -4042,12 +3980,8 @@ S_my_exit_jump(pTHX)
     JMPENV_JUMP(2);
 }
 
-#ifdef PERL_OBJECT
-#include "XSUB.h"
-#endif
-
 static I32
-read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
+read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
 {
     char *p, *nl;
     p  = SvPVX(PL_e_script);