re-add missing Unicode database master
[p5sagit/p5-mst-13.2.git] / doio.c
diff --git a/doio.c b/doio.c
index 7620e3a..4a0edbb 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -134,14 +134,14 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
        else
            result = PerlIO_close(IoIFP(io));
        if (result == EOF && fd > PL_maxsysfd)
-           PerlIO_printf(PerlIO_stderr(),
+           PerlIO_printf(Perl_error_log,
                          "Warning: unable to close filehandle %s properly.\n",
                          GvENAME(gv));
        IoOFP(io) = IoIFP(io) = Nullfp;
     }
 
     if (as_raw) {
-#if defined(O_LARGEFILE)
+#if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
        rawmode |= O_LARGEFILE;
 #endif
 
@@ -282,7 +282,19 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                            goto say_false;
                        }
                        if (IoIFP(thatio)) {
-                           fd = PerlIO_fileno(IoIFP(thatio));
+                           PerlIO *fp = IoIFP(thatio);
+                           /* Flush stdio buffer before dup. --mjd
+                            * Unfortunately SEEK_CURing 0 seems to
+                            * be optimized away on most platforms;
+                            * only Solaris and Linux seem to flush
+                            * on that. --jhi */
+                           PerlIO_seek(fp, 0, SEEK_CUR);
+                           /* On the other hand, do all platforms
+                            * take gracefully to flushing a read-only
+                            * filehandle?  Perhaps we should do
+                            * fsetpos(src)+fgetpos(dst)?  --nik */
+                           PerlIO_flush(fp);
+                           fd = PerlIO_fileno(fp);
                            if (IoTYPE(thatio) == 's')
                                IoTYPE(io) = 's';
                        }
@@ -413,7 +425,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            }
        }
        if (fd != PerlIO_fileno(fp)) {
-           int pid;
+           Pid_t pid;
            SV *sv;
 
            PerlLIO_dup2(PerlIO_fileno(fp), fd);
@@ -472,9 +484,18 @@ Perl_nextargv(pTHX_ register GV *gv)
 #endif
     Uid_t fileuid;
     Gid_t filegid;
+    IO *io = GvIOp(gv);
 
     if (!PL_argvoutgv)
        PL_argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO);
+    if (io && (IoFLAGS(io) & IOf_ARGV) && (IoFLAGS(io) & IOf_START)) {
+       IoFLAGS(io) &= ~IOf_START;
+       if (PL_inplace) {
+           if (!PL_argvout_stack)
+               PL_argvout_stack = newAV();
+           av_push(PL_argvout_stack, SvREFCNT_inc(PL_defoutgv));
+       }
+    }
     if (PL_filemode & (S_ISUID|S_ISGID)) {
        PerlIO_flush(IoIFP(GvIOn(PL_argvoutgv)));  /* chmod must follow last write */
 #ifdef HAS_FCHMOD
@@ -598,11 +619,12 @@ Perl_nextargv(pTHX_ register GV *gv)
                SETERRNO(0,0);          /* in case sprintf set errno */
 #ifdef VMS
                if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
-                 O_WRONLY|O_CREAT|O_TRUNC,0,Nullfp)) { 
+                 O_WRONLY|O_CREAT|O_TRUNC,0,Nullfp))
 #else
                if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
-                            O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp)) {
+                            O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp))
 #endif
+               {
                    if (ckWARN_d(WARN_INPLACE)) 
                        Perl_warner(aTHX_ WARN_INPLACE, "Can't do inplace edit on %s: %s",
                          PL_oldname, Strerror(errno) );
@@ -645,8 +667,18 @@ Perl_nextargv(pTHX_ register GV *gv)
            }
        }
     }
+    if (io && (IoFLAGS(io) & IOf_ARGV))
+       IoFLAGS(io) |= IOf_START;
     if (PL_inplace) {
        (void)do_close(PL_argvoutgv,FALSE);
+       if (io && (IoFLAGS(io) & IOf_ARGV)
+           && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0)
+       {
+           GV *oldout = (GV*)av_pop(PL_argvout_stack);
+           setdefout(oldout);
+           SvREFCNT_dec(oldout);
+           return Nullfp;
+       }
        setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
     }
     return Nullfp;
@@ -873,7 +905,7 @@ Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
            Perl_warner(aTHX_ WARN_UNOPENED, "sysseek() on unopened file");
     }
     SETERRNO(EBADF,RMS$_IFI);
-    return -1L;
+    return (Off_t)-1;
 }
 
 int
@@ -1001,17 +1033,10 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
        if (SvIOK(sv)) {
            if (SvGMAGICAL(sv))
                mg_get(sv);
-#ifdef IV_IS_QUAD
-           if (SvIsUV(sv))
-               PerlIO_printf(fp, "%" PERL_PRIu64, (UV)SvUVX(sv));
-           else
-               PerlIO_printf(fp, "%" PERL_PRId64, (IV)SvIVX(sv));
-#else
            if (SvIsUV(sv))
-               PerlIO_printf(fp, "%lu", (unsigned long)SvUVX(sv));
+               PerlIO_printf(fp, "%"UVuf, (UV)SvUVX(sv));
            else
-               PerlIO_printf(fp, "%ld", (long)SvIVX(sv));
-#endif
+               PerlIO_printf(fp, "%"IVdf, (IV)SvIVX(sv));
            return !PerlIO_error(fp);
        }
        /* FALL THROUGH */
@@ -1019,6 +1044,12 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
        tmps = SvPV(sv, len);
        break;
     }
+    /* To detect whether the process is about to overstep its
+     * filesize limit we would need getrlimit().  We could then
+     * also transparently raise the limit with setrlimit() --
+     * but only until the system hard limit/the filesystem limit,
+     * at which we would get EPERM.  Note that when using buffered
+     * io the write failure can be delayed until the flush/close. --jhi */
     if (len && (PerlIO_write(fp,tmps,len) == 0 || PerlIO_error(fp)))
        return FALSE;
     return !PerlIO_error(fp);
@@ -1033,7 +1064,7 @@ Perl_my_stat(pTHX)
 
     if (PL_op->op_flags & OPf_REF) {
        EXTEND(SP,1);
-       tmpgv = cGVOP->op_gv;
+       tmpgv = cGVOP_gv;
       do_fstat:
        io = GvIO(tmpgv);
        if (io && IoIFP(io)) {
@@ -1086,7 +1117,7 @@ Perl_my_lstat(pTHX)
     STRLEN n_a;
     if (PL_op->op_flags & OPf_REF) {
        EXTEND(SP,1);
-       if (cGVOP->op_gv == PL_defgv) {
+       if (cGVOP_gv == PL_defgv) {
            if (PL_laststype != OP_LSTAT)
                Perl_croak(aTHX_ "The stat preceding -l _ wasn't an lstat");
            return PL_laststatval;
@@ -1115,6 +1146,9 @@ bool
 Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp,
               int fd, int do_report)
 {
+#ifdef MACOS_TRADITIONAL
+    Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
+#else
     register char **a;
     char *tmps;
     STRLEN n_a;
@@ -1147,6 +1181,7 @@ Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp,
        }
     }
     do_execfree();
+#endif
     return FALSE;
 }
 
@@ -1163,7 +1198,7 @@ Perl_do_execfree(pTHX)
     }
 }
 
-#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC)
+#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
 
 bool
 Perl_do_exec(pTHX_ char *cmd)
@@ -1487,9 +1522,10 @@ nothing in the core.
 
 /* Do the permissions allow some operation?  Assumes statcache already set. */
 #ifndef VMS /* VMS' cando is in vms.c */
-I32
-Perl_cando(pTHX_ I32 bit, Uid_t effective, register struct stat *statbufp)
-/* Note: we use `effective' both for uids and gids. */
+bool
+Perl_cando(pTHX_ Mode_t mode, Uid_t effective, register Stat_t *statbufp)
+/* Note: we use `effective' both for uids and gids.
+ * Here we are betting on Uid_t being equal or wider than Gid_t.  */
 {
 #ifdef DOSISH
     /* [Comments and code from Len Reed]
@@ -1513,11 +1549,11 @@ Perl_cando(pTHX_ I32 bit, Uid_t effective, register struct stat *statbufp)
      /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
       * too so it will actually look into the files for magic numbers
       */
-     return (bit & statbufp->st_mode) ? TRUE : FALSE;
+     return (mode & statbufp->st_mode) ? TRUE : FALSE;
 
 #else /* ! DOSISH */
     if ((effective ? PL_euid : PL_uid) == 0) { /* root is special */
-       if (bit == S_IXUSR) {
+       if (mode == S_IXUSR) {
            if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
                return TRUE;
        }
@@ -1526,14 +1562,14 @@ Perl_cando(pTHX_ I32 bit, Uid_t effective, register struct stat *statbufp)
        return FALSE;
     }
     if (statbufp->st_uid == (effective ? PL_euid : PL_uid) ) {
-       if (statbufp->st_mode & bit)
+       if (statbufp->st_mode & mode)
            return TRUE;        /* ok as "user" */
     }
     else if (ingroup(statbufp->st_gid,effective)) {
-       if (statbufp->st_mode & bit >> 3)
+       if (statbufp->st_mode & mode >> 3)
            return TRUE;        /* ok as "group" */
     }
-    else if (statbufp->st_mode & bit >> 6)
+    else if (statbufp->st_mode & mode >> 6)
        return TRUE;    /* ok as "other" */
     return FALSE;
 #endif /* ! DOSISH */
@@ -1543,6 +1579,10 @@ Perl_cando(pTHX_ I32 bit, Uid_t effective, register struct stat *statbufp)
 bool
 Perl_ingroup(pTHX_ Gid_t testgid, Uid_t effective)
 {
+#ifdef MACOS_TRADITIONAL
+    /* This is simply not correct for AppleShare, but fix it yerself. */
+    return TRUE;
+#else
     if (testgid == (effective ? PL_egid : PL_gid))
        return TRUE;
 #ifdef HAS_GETGROUPS
@@ -1560,6 +1600,7 @@ Perl_ingroup(pTHX_ Gid_t testgid, Uid_t effective)
     }
 #endif
     return FALSE;
+#endif
 }
 
 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
@@ -1677,7 +1718,7 @@ Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
     else
     {
        IV i = SvIV(astr);
-       a = (char *)i;          /* ouch */
+       a = INT2PTR(char *,i);          /* ouch */
     }
     SETERRNO(0,0);
     switch (optype)