Integrate perlio:

[  7711]
Minor tweaks:
consistent way of getting 'rb', 'wb' etc. for binary opens
move *perlio::layers to *open::layers
a #define to show layers available
DOSISH popen/PerlIO had export/import sense inverted.

p4raw-link: @7711 on //depot/perlio: a1d180c4a5147aa338f86b44d91b356bec0875ac

p4raw-id: //depot/perl@7713

diff --git a/doio.c b/doio.c
index e4724ef..05ace5e 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -234,17 +234,13 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                if (ckWARN(WARN_PIPE))
                    Perl_warner(aTHX_ WARN_PIPE, "Can't open bidirectional pipe");
            }
-           {
-               char *mode;
-               if (out_raw)
-                   mode = "wb";
-               else if (out_crlf)
-                   mode = "wt";
-               else
-                   mode = "w";
-               fp = PerlProc_popen(name,mode);
-           }
+           mode[0] = 'w';
            writing = 1;
+           if (out_raw)
+               strcat(mode, "b");
+           else if (out_crlf)
+               strcat(mode, "t");
+           fp = PerlProc_popen(name,mode);
        }
        else if (*type == IoTYPE_WRONLY) {
            TAINT_PROPER("open");
@@ -394,16 +390,12 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            if (strNE(name,"-") || num_svs)
                TAINT_ENV();
            TAINT_PROPER("piped open");
-           {
-               char *mode;
-               if (in_raw)
-                   mode = "rb";
-               else if (in_crlf)
-                   mode = "rt";
-               else
-                   mode = "r";
-               fp = PerlProc_popen(name,mode);
-           }
+           mode[0] = 'r';
+           if (in_raw)
+               strcat(mode, "b");
+           else if (in_crlf)
+               strcat(mode, "t");
+           fp = PerlProc_popen(name,mode);
            IoTYPE(io) = IoTYPE_PIPE;
        }
        else {
@@ -418,13 +410,11 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                IoTYPE(io) = IoTYPE_STD;
            }
            else {
-               char *mode;
+               mode[0] = 'r';
                if (in_raw)
-                   mode = "rb";
+                   strcat(mode, "b");
                else if (in_crlf)
-                   mode = "rt";
-               else
-                   mode = "r";
+                   strcat(mode, "t");
                fp = PerlIO_open(name,mode);
            }
        }
@@ -634,7 +624,7 @@ Perl_nextargv(pTHX_ register GV *gv)
 #if !defined(DOSISH) && !defined(__CYGWIN__)
                    if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) {
                        if (ckWARN_d(WARN_INPLACE))     
-                           Perl_warner(aTHX_ WARN_INPLACE, 
+                           Perl_warner(aTHX_ WARN_INPLACE,
                              "Can't rename %s to %s: %s, skipping file",
                              PL_oldname, SvPVX(sv), Strerror(errno) );
                        do_close(gv,FALSE);
@@ -881,7 +871,7 @@ Perl_do_eof(pTHX_ GV *gv)
                 || IoIFP(io) == PerlIO_stderr()))
     {
        /* integrate to report_evil_fh()? */
-        char *name = NULL; 
+        char *name = NULL;
        if (isGV(gv)) {
            SV* sv = sv_newmortal();
            gv_efullname4(sv, gv, Nullch, FALSE);
@@ -1305,7 +1295,7 @@ Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp,
        else
            PerlProc_execvp(PL_Argv[0],PL_Argv);
        if (ckWARN(WARN_EXEC))
-           Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s", 
+           Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s",
                PL_Argv[0], Strerror(errno));
        if (do_report) {
            int e = errno;
@@ -1440,7 +1430,7 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report)
            int e = errno;
 
            if (ckWARN(WARN_EXEC))
-               Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s", 
+               Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s",
                    PL_Argv[0], Strerror(errno));
            if (do_report) {
                PerlLIO_write(fd, (void*)&e, sizeof(int));
@@ -1515,7 +1505,7 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
        }
        break;
 #endif
-/* 
+/*
 XXX Should we make lchown() directly available from perl?
 For now, we'll let Configure test for HAS_LCHOWN, but do
 nothing in the core.
@@ -1940,7 +1930,7 @@ Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
     flags = SvIVx(*++mark);
     SvPV_force(mstr, len);
     mbuf = SvGROW(mstr, sizeof(long)+msize+1);
-    
+
     SETERRNO(0,0);
     ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
     if (ret >= 0) {

diff --git a/perlio.c b/perlio.c
index da1d8ac..f5135ca 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -287,8 +287,8 @@ PerlIO_default_layer(I32 n)
    char *s  = PerlEnv_getenv("PERLIO");
    newXS("perlio::import",XS_perlio_import,__FILE__);
    newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
-   PerlIO_layer_hv = get_hv("perlio::layers",GV_ADD|GV_ADDMULTI);
-   PerlIO_layer_av = get_av("perlio::layers",GV_ADD|GV_ADDMULTI);
+   PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
+   PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
    PerlIO_define_layer(&PerlIO_unix);
    PerlIO_define_layer(&PerlIO_perlio);
    PerlIO_define_layer(&PerlIO_stdio);

diff --git a/perlio.h b/perlio.h
index d8ea15a..fd9aa3b 100644 (file)
--- a/perlio.h
+++ b/perlio.h
@@ -78,8 +78,10 @@ typedef struct _PerlIO PerlIOl;
 typedef struct _PerlIO_funcs PerlIO_funcs;
 typedef PerlIOl *PerlIO;
 #define PerlIO PerlIO
+#define PERLIO_LAYERS 1
 
 extern void    PerlIO_define_layer     (PerlIO_funcs *tab);
+extern SV *    PerlIO_find_layer(char *name, STRLEN len);
 extern PerlIO *        PerlIO_push             (PerlIO *f,PerlIO_funcs *tab,const char *mode);
 extern void    PerlIO_pop              (PerlIO *f);
 

diff --git a/util.c b/util.c
index 6a68fe6..2168d55 100644 (file)
--- a/util.c
+++ b/util.c
@@ -115,7 +115,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
     Malloc_t PerlMem_realloc();
 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
 
-#ifdef HAS_64K_LIMIT 
+#ifdef HAS_64K_LIMIT
     if (size > 0xffff) {
        PerlIO_printf(Perl_error_log,
                      "Reallocation too large: %lx\n", size) FLUSH;
@@ -135,7 +135,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 #endif
     ptr = (Malloc_t)PerlMem_realloc(where,size);
     PERL_ALLOC_CHECK(ptr);
- 
+
     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
 
@@ -245,12 +245,12 @@ Perl_safexrealloc(Malloc_t wh, MEM_SIZE size)
 
     if (!wh)
        return safexmalloc(0,size);
-    
+
     {
        MEM_SIZE old = sizeof_chunk(where - ALIGN);
        int t = typeof_chunk(where - ALIGN);
        register char* new = (char*)saferealloc(where - ALIGN, size + ALIGN);
-    
+
        xycount[t][SIZE_TO_Y(old)]--;
        xycount[t][SIZE_TO_Y(size)]++;
        xcount[t] += size - old;
@@ -265,7 +265,7 @@ Perl_safexfree(Malloc_t wh)
     I32 x;
     char *where = (char*)wh;
     MEM_SIZE size;
-    
+
     if (!where)
        return;
     where -= ALIGN;
@@ -297,7 +297,7 @@ S_xstat(pTHX_ int flag)
     for (j = 0; j < MAXYCOUNT; j++) {
        subtot[j] = 0;
     }
-    
+
     PerlIO_printf(Perl_debug_log, "   Id  subtot   4   8  12  16  20  24  28  32  36  40  48  56  64  72  80 80+\n", total);
     for (i = 0; i < MAXXCOUNT; i++) {
        total += xcount[i];
@@ -306,21 +306,21 @@ S_xstat(pTHX_ int flag)
        }
        if (flag == 0
            ? xcount[i]                 /* Have something */
-           : (flag == 2 
+           : (flag == 2
               ? xcount[i] != lastxcount[i] /* Changed */
               : xcount[i] > lastxcount[i])) { /* Growed */
-           PerlIO_printf(Perl_debug_log,"%2d %02d %7ld ", i / 100, i % 100, 
+           PerlIO_printf(Perl_debug_log,"%2d %02d %7ld ", i / 100, i % 100,
                          flag == 2 ? xcount[i] - lastxcount[i] : xcount[i]);
            lastxcount[i] = xcount[i];
            for (j = 0; j < MAXYCOUNT; j++) {
-               if ( flag == 0 
+               if ( flag == 0
                     ? xycount[i][j]    /* Have something */
-                    : (flag == 2 
+                    : (flag == 2
                        ? xycount[i][j] != lastxycount[i][j] /* Changed */
                        : xycount[i][j] > lastxycount[i][j])) { /* Growed */
-                   PerlIO_printf(Perl_debug_log,"%3ld ", 
-                                 flag == 2 
-                                 ? xycount[i][j] - lastxycount[i][j] 
+                   PerlIO_printf(Perl_debug_log,"%3ld ",
+                                 flag == 2
+                                 ? xycount[i][j] - lastxycount[i][j]
                                  : xycount[i][j]);
                    lastxycount[i][j] = xycount[i][j];
                } else {
@@ -759,18 +759,18 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
 
     if (setlocale_failure) {
        char *p;
-       bool locwarn = (printwarn > 1 || 
+       bool locwarn = (printwarn > 1 ||
                        (printwarn &&
                         (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))));
 
        if (locwarn) {
 #ifdef LC_ALL
-  
+
            PerlIO_printf(Perl_error_log,
               "perl: warning: Setting locale failed.\n");
 
 #else /* !LC_ALL */
-  
+
            PerlIO_printf(Perl_error_log,
               "perl: warning: Setting locale failed for the categories:\n\t");
 #ifdef USE_LOCALE_CTYPE
@@ -1070,9 +1070,9 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
     register I32 multiline = flags & FBMrf_MULTILINE;
 
     if (bigend - big < littlelen) {
-       if ( SvTAIL(littlestr) 
+       if ( SvTAIL(littlestr)
             && (bigend - big == littlelen - 1)
-            && (littlelen == 1 
+            && (littlelen == 1
                 || (*big == *little &&
                     memEQ((char *)big, (char *)little, littlelen - 1))))
            return (char*)big;
@@ -1164,7 +1164,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
     }
     if (SvTAIL(littlestr) && !multiline) {     /* tail anchored? */
        s = bigend - littlelen;
-       if (s >= big && bigend[-1] == '\n' && *s == *little 
+       if (s >= big && bigend[-1] == '\n' && *s == *little
            /* Automatically of length > 2 */
            && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
        {
@@ -1193,7 +1193,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
        }
        return b;
     }
-    
+
     {  /* Do actual FBM.  */
        register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
        register unsigned char *oldlittle;
@@ -1253,7 +1253,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
    of ends of some substring of bigstr.
    If `last' we want the last occurence.
    old_posp is the way of communication between consequent calls if
-   the next call needs to find the . 
+   the next call needs to find the .
    The initial *old_posp should be -1.
 
    Note that we take into account SvTAIL, so one can get extra
@@ -1282,7 +1282,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
        ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
        : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
       cant_find:
-       if ( BmRARE(littlestr) == '\n' 
+       if ( BmRARE(littlestr) == '\n'
             && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
            little = (unsigned char *)(SvPVX(littlestr));
            littleend = little + SvCUR(littlestr);
@@ -1345,7 +1345,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
            found = 1;
        }
     } while ( pos += PL_screamnext[pos] );
-    if (last && found) 
+    if (last && found)
        return (char *)(big+(*old_posp));
 #endif /* POINTERRIGOR */
   check_tail:
@@ -1532,7 +1532,7 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
                              SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
            Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
                      PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
-                     line_mode ? "line" : "chunk", 
+                     line_mode ? "line" : "chunk",
                      (IV)IoLINES(GvIOp(PL_last_in_gv)));
        }
 #ifdef USE_THREADS
@@ -1813,7 +1813,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args)
 
        PerlIO_write(serr, message, msglen);
 #ifdef LEAKTEST
-       DEBUG_L(*message == '!' 
+       DEBUG_L(*message == '!'
                ? (xstat(message[1]=='!'
                         ? (message[2]=='!' ? 2 : 1)
                         : 0)
@@ -1905,13 +1905,13 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
             if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
                 dSP;
                 SV *msg;
- 
+
                 ENTER;
                save_re_context();
                 msg = newSVpvn(message, msglen);
                 SvREADONLY_on(msg);
                 SAVEFREESV(msg);
- 
+
                PUSHSTACKi(PERLSI_DIEHOOK);
                 PUSHMARK(sp);
                 XPUSHs(msg);
@@ -1946,13 +1946,13 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
             if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
                 dSP;
                 SV *msg;
- 
+
                 ENTER;
                save_re_context();
                 msg = newSVpvn(message, msglen);
                 SvREADONLY_on(msg);
                 SAVEFREESV(msg);
- 
+
                PUSHSTACKi(PERLSI_WARNHOOK);
                 PUSHMARK(sp);
                 XPUSHs(msg);
@@ -1967,7 +1967,7 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
            PerlIO *serr = Perl_error_log;
            PerlIO_write(serr, message, msglen);
 #ifdef LEAKTEST
-           DEBUG_L(*message == '!' 
+           DEBUG_L(*message == '!'
                ? (xstat(message[1]=='!'
                         ? (message[2]=='!' ? 2 : 1)
                         : 0)
@@ -2371,7 +2371,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
     if (doexec) {
        return my_syspopen(aTHX_ cmd,mode);
     }
-#endif 
+#endif
     This = (*mode == 'w');
     that = !This;
     if (doexec && PL_tainting) {
@@ -2484,10 +2484,12 @@ FILE *popen();
 PerlIO *
 Perl_my_popen(pTHX_ char *cmd, char *mode)
 {
-    /* Needs work for PerlIO ! */
-    /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */
     PERL_FLUSHALL_FOR_CHILD;
-    return popen(PerlIO_exportFILE(cmd, 0), mode);
+    /* Call system's popen() to get a FILE *, then import it.
+       used 0 for 2nd parameter to PerlIO_importFILE;
+       apparently not used
+    */
+    return PerlIO_importFILE(popen(cmd, mode), 0);
 }
 #endif
 
@@ -2677,7 +2679,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     if (pid == -1) {                   /* Opened by popen. */
        return my_syspclose(ptr);
     }
-#endif 
+#endif
     if ((close_failed = (PerlIO_close(ptr) == EOF))) {
        saved_errno = errno;
 #ifdef VMS
@@ -2796,7 +2798,7 @@ my_syspclose(PerlIO *ptr)
 #else
 I32
 Perl_my_pclose(pTHX_ PerlIO *ptr)
-#endif 
+#endif
 {
     /* Needs work for PerlIO ! */
     FILE *f = PerlIO_findFILE(ptr);
@@ -2860,7 +2862,7 @@ Perl_cast_ulong(pTHX_ NV f)
 /* Code modified to prefer proper named type ranges, I32, IV, or UV, instead
    of LONG_(MIN/MAX).
                            -- Kenneth Albanowski <kjahds@kjahds.com>
-*/                                      
+*/
 
 #ifndef MY_UV_MAX
 #  define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1)
@@ -3006,7 +3008,7 @@ Perl_scan_bin(pTHX_ char *start, STRLEN len, STRLEN *retlen)
 #if UVSIZE > 4
        || (!overflowed && ruv > 0xffffffff  )
 #endif
-       ) { 
+       ) {
        dTHR;
        if (ckWARN(WARN_PORTABLE))
            Perl_warner(aTHX_ WARN_PORTABLE,
@@ -3149,7 +3151,7 @@ Perl_scan_hex(pTHX_ char *start, STRLEN len, STRLEN *retlen)
 #if UVSIZE > 4
        || (!overflowed && ruv > 0xffffffff  )
 #endif
-       ) { 
+       ) {
        dTHR;
        if (ckWARN(WARN_PORTABLE))
            Perl_warner(aTHX_ WARN_PORTABLE,
@@ -3370,7 +3372,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f
        }
 #ifndef DOSISH
        if (!xfound && !seen_dot && !xfailed &&
-           (PerlLIO_stat(scriptname,&PL_statbuf) < 0 
+           (PerlLIO_stat(scriptname,&PL_statbuf) < 0
             || S_ISDIR(PL_statbuf.st_mode)))
 #endif
            seen_dot = 1;                       /* Disable message. */
@@ -3450,7 +3452,7 @@ Perl_cond_signal(pTHX_ perl_cond *cp)
 {
     perl_os_thread t;
     perl_cond cond = *cp;
-    
+
     if (!cond)
        return;
     t = cond->thread;
@@ -3470,7 +3472,7 @@ Perl_cond_broadcast(pTHX_ perl_cond *cp)
 {
     perl_os_thread t;
     perl_cond cond, cond_next;
-    
+
     for (cond = *cp; cond; cond = cond_next) {
        t = cond->thread;
        /* Insert t in the runnable queue just ahead of us */
@@ -3493,7 +3495,7 @@ Perl_cond_wait(pTHX_ perl_cond *cp)
 
     if (thr->i.next_run == thr)
        Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread");
-    
+
     New(666, cond, 1, struct perl_wait_queue);
     cond->thread = thr;
     cond->next = *cp;
@@ -3509,7 +3511,7 @@ MAGIC *
 Perl_condpair_magic(pTHX_ SV *sv)
 {
     MAGIC *mg;
-    
+
     SvUPGRADE(sv, SVt_PVMG);
     mg = mg_find(sv, 'm');
     if (!mg) {
@@ -3681,7 +3683,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t)
                "new_struct_thread: copied threadsv %"IVdf" %p->%p\n",
                                  (IV)i, t, thr));
        }
-    } 
+    }
     thr->threadsvp = AvARRAY(thr->threadsv);
 
     MUTEX_LOCK(&PL_threads_mutex);
@@ -3706,10 +3708,10 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t)
 #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
 /*
  * This hack is to force load of "huge" support from libm.a
- * So it is in perl for (say) POSIX to use. 
+ * So it is in perl for (say) POSIX to use.
  * Needed for SunOS with Sun's 'acc' for example.
  */
-NV 
+NV
 Perl_huge(void)
 {
 #   if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)