VMS build tweaks (from Charles Bailey)

[p5sagit/p5-mst-13.2.git] / pp_sys.c

diff --git a/pp_sys.c b/pp_sys.c
index 9e3ad52..976f5a1 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -304,9 +304,14 @@ PP(pp_backtick)
     STRLEN n_a;
     char *tmps = POPpx;
     I32 gimme = GIMME_V;
+    char *mode = "r";
 
     TAINT_PROPER("``");
-    fp = PerlProc_popen(tmps, "r");
+    if (PL_op->op_private & OPpOPEN_IN_RAW)
+       mode = "rb";
+    else if (PL_op->op_private & OPpOPEN_IN_CRLF)
+       mode = "rt";
+    fp = PerlProc_popen(tmps, mode);
     if (fp) {
        if (gimme == G_VOID) {
            char tmpbuf[256];
@@ -356,6 +361,10 @@ PP(pp_glob)
     OP *result;
     tryAMAGICunTARGET(iter, -1);
 
+    /* Note that we only ever get here if File::Glob fails to load
+     * without at the same time croaking, for some reason, or if
+     * perl was built with PERL_EXTERNAL_GLOB */
+
     ENTER;
 
 #ifndef VMS
@@ -517,7 +526,7 @@ PP(pp_open)
     if (GvIOp(gv))
        IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
 
-    if (mg = SvTIED_mg((SV*)gv, 'q')) {
+    if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
        PUSHMARK(SP);
        XPUSHs(SvTIED_obj((SV*)gv, mg));
        XPUSHs(sv);
@@ -552,7 +561,7 @@ PP(pp_close)
     else
        gv = (GV*)POPs;
 
-    if (mg = SvTIED_mg((SV*)gv, 'q')) {
+    if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
        PUSHMARK(SP);
        XPUSHs(SvTIED_obj((SV*)gv, mg));
        PUTBACK;
@@ -683,15 +692,20 @@ PP(pp_binmode)
     IO *io;
     PerlIO *fp;
     MAGIC *mg;
+    SV *discp = Nullsv;
 
     if (MAXARG < 1)
        RETPUSHUNDEF;
+    if (MAXARG > 1)
+       discp = POPs;
 
     gv = (GV*)POPs; 
 
     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
        PUSHMARK(SP);
        XPUSHs(SvTIED_obj((SV*)gv, mg));
+       if (discp)
+           XPUSHs(discp);
        PUTBACK;
        ENTER;
        call_method("BINMODE", G_SCALAR);
@@ -704,13 +718,12 @@ PP(pp_binmode)
     if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
        RETPUSHUNDEF;
 
-    if (do_binmode(fp,IoTYPE(io),TRUE)) 
+    if (do_binmode(fp,IoTYPE(io),mode_from_discipline(discp))) 
        RETPUSHYES;
     else
        RETPUSHUNDEF;
 }
 
-
 PP(pp_tie)
 {
     djSP;
@@ -793,7 +806,7 @@ PP(pp_untie)
 
     if (ckWARN(WARN_UNTIE)) {
         MAGIC * mg ;
-        if (mg = SvTIED_mg(sv, how)) {
+        if ((mg = SvTIED_mg(sv, how))) {
             if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)  
                Perl_warner(aTHX_ WARN_UNTIE,
                    "untie attempted while %"UVuf" inner references still exist",
@@ -812,7 +825,7 @@ PP(pp_tied)
     char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
     MAGIC *mg;
 
-    if (mg = SvTIED_mg(sv, how)) {
+    if ((mg = SvTIED_mg(sv, how))) {
        SV *osv = SvTIED_obj(sv, mg);
        if (osv == mg->mg_obj)
            osv = sv_mortalcopy(osv);
@@ -928,7 +941,7 @@ PP(pp_sselect)
     /* If SELECT_MIN_BITS is greater than one we most probably will want
      * to align the sizes with SELECT_MIN_BITS/8 because for example
      * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
-     * UNIX, Solaris, NeXT, Rhapsody) the smallest quantum select() operates
+     * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
      * on (sets/tests/clears bits) is 32 bits.  */
     growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
 #  else
@@ -1076,12 +1089,12 @@ PP(pp_getc)
     GV *gv;
     MAGIC *mg;
 
-    if (MAXARG <= 0)
+    if (MAXARG == 0)
        gv = PL_stdingv;
     else
        gv = (GV*)POPs;
 
-    if (mg = SvTIED_mg((SV*)gv, 'q')) {
+    if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
        I32 gimme = GIMME_V;
        PUSHMARK(SP);
        XPUSHs(SvTIED_obj((SV*)gv, mg));
@@ -1305,7 +1318,7 @@ PP(pp_prtf)
     else
        gv = PL_defoutgv;
 
-    if (mg = SvTIED_mg((SV*)gv, 'q')) {
+    if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
        if (MARK == ORIGMARK) {
            MEXTEND(SP, 1);
            ++MARK;
@@ -1686,7 +1699,7 @@ PP(pp_eof)
     GV *gv;
     MAGIC *mg;
 
-    if (MAXARG <= 0) {
+    if (MAXARG == 0) {
        if (PL_op->op_flags & OPf_SPECIAL) {    /* eof() */
            IO *io;
            gv = PL_last_in_gv = PL_argvgv;
@@ -1730,7 +1743,7 @@ PP(pp_tell)
     GV *gv;     
     MAGIC *mg;
 
-    if (MAXARG <= 0)
+    if (MAXARG == 0)
        gv = PL_last_in_gv;
     else
        gv = PL_last_in_gv = (GV*)POPs;
@@ -1965,7 +1978,7 @@ PP(pp_flock)
 
 #ifdef FLOCK
     argtype = POPi;
-    if (MAXARG <= 0)
+    if (MAXARG == 0)
        gv = PL_last_in_gv;
     else
        gv = (GV*)POPs;
@@ -3074,9 +3087,26 @@ PP(pp_fttext)
 #else
        else if (*s & 128) {
 #ifdef USE_LOCALE
-           if (!(PL_op->op_private & OPpLOCALE) || !isALPHA_LC(*s))
-#endif
-               odd++;
+           if ((PL_op->op_private & OPpLOCALE) && isALPHA_LC(*s))
+               continue;
+#endif
+           /* utf8 characters don't count as odd */
+           if (*s & 0x40) {
+               int ulen = UTF8SKIP(s);
+               if (ulen < len - i) {
+                   int j;
+                   for (j = 1; j < ulen; j++) {
+                       if ((s[j] & 0xc0) != 0x80)
+                           goto not_utf8;
+                   }
+                   --ulen;     /* loop does extra increment */
+                   s += ulen;
+                   i += ulen;
+                   continue;
+               }
+           }
+         not_utf8:
+           odd++;
        }
        else if (*s < 32 &&
          *s != '\n' && *s != '\r' && *s != '\b' &&
@@ -3455,14 +3485,15 @@ PP(pp_readdir)
 
     if (GIMME == G_ARRAY) {
        /*SUPPRESS 560*/
-       while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
+       while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
 #ifdef DIRNAMLEN
            sv = newSVpvn(dp->d_name, dp->d_namlen);
 #else
            sv = newSVpv(dp->d_name, 0);
 #endif
 #ifndef INCOMPLETE_TAINTS
-           SvTAINTED_on(sv);
+           if (!(IoFLAGS(io) & IOf_UNTAINT))
+               SvTAINTED_on(sv);
 #endif
            XPUSHs(sv_2mortal(sv));
        }
@@ -3476,7 +3507,8 @@ PP(pp_readdir)
        sv = newSVpv(dp->d_name, 0);
 #endif
 #ifndef INCOMPLETE_TAINTS
-       SvTAINTED_on(sv);
+       if (!(IoFLAGS(io) & IOf_UNTAINT))
+           SvTAINTED_on(sv);
 #endif
        XPUSHs(sv_2mortal(sv));
     }
@@ -3612,7 +3644,7 @@ PP(pp_fork)
        RETSETUNDEF;
     if (!childpid) {
        /*SUPPRESS 560*/
-       if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
+       if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
            sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
        hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
     }
@@ -4029,7 +4061,6 @@ PP(pp_gmtime)
     EXTEND(SP, 9);
     EXTEND_MORTAL(9);
     if (GIMME != G_ARRAY) {
-       dTARGET;
        SV *tsv;
        if (!tmbuf)
            RETPUSHUNDEF;
@@ -4987,7 +5018,6 @@ PP(pp_syscall)
     unsigned long a[20];
     register I32 i = 0;
     I32 retval = -1;
-    MAGIC *mg;
     STRLEN n_a;
 
     if (PL_tainting) {