Zero-padded Numerics in Perl Format

Message-ID: <3924126F.A58BE57A@UnivPress.com>

p4raw-id: //depot/perl@7444

diff --git a/form.h b/form.h
index ca2a0c8..4c08bbd 100644 (file)
--- a/form.h
+++ b/form.h
@@ -23,4 +23,5 @@
 #define FF_NEWLINE     13
 #define FF_BLANK       14
 #define FF_MORE                15
+#define FF_0DECIMAL   16
 

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 95dd6c5..72a2904 100644 (file)
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -109,6 +109,10 @@ functionality, see pack('U0', ...) and pack('C0', ...).
 
 =item *
 
+Formats now support zero-padded decimal fields.
+
+=item *
+
 C<perl -d:Module=arg,arg,arg> now works (previously one couldn't pass
 in multiple arguments.)
 

diff --git a/pp_ctl.c b/pp_ctl.c
index a65cb1b..729a438 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -342,6 +342,7 @@ PP(pp_formline)
            case FF_MORE:       name = "MORE";          break;
            case FF_LINEMARK:   name = "LINEMARK";      break;
            case FF_END:        name = "END";           break;
+            case FF_0DECIMAL:  name = "0DECIMAL";      break;
            }
            if (arg >= 0)
                PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
@@ -620,6 +621,43 @@ PP(pp_formline)
            t += fieldsize;
            break;
 
+       case FF_0DECIMAL:
+           /* If the field is marked with ^ and the value is undefined,
+              blank it out. */
+           arg = *fpc++;
+           if ((arg & 512) && !SvOK(sv)) {
+               arg = fieldsize;
+               while (arg--)
+                   *t++ = ' ';
+               break;
+           }
+           gotsome = TRUE;
+           value = SvNV(sv);
+           /* Formats aren't yet marked for locales, so assume "yes". */
+           {
+               STORE_NUMERIC_STANDARD_SET_LOCAL();
+#if defined(USE_LONG_DOUBLE)
+               if (arg & 256) {
+                   sprintf(t, "%#0*.*" PERL_PRIfldbl,
+                           (int) fieldsize, (int) arg & 255, value); 
+/* is this legal? I don't have long doubles */      
+               } else {
+                   sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
+               }
+#else
+               if (arg & 256) {
+                   sprintf(t, "%#0*.*f",
+                           (int) fieldsize, (int) arg & 255, value);
+               } else {
+                   sprintf(t, "%0*.0f",
+                           (int) fieldsize, value);
+               }
+#endif
+               RESTORE_NUMERIC_STANDARD();
+           }
+           t += fieldsize;
+           break;
+           
        case FF_NEWLINE:
            f++;
            while (t-- > linemark && *t == ' ') ;
@@ -3632,6 +3670,24 @@ S_doparseform(pTHX_ SV *sv)
                }
                *fpc++ = s - base;              /* fieldsize for FETCH */
                *fpc++ = FF_DECIMAL;
+                *fpc++ = arg;
+            }
+            else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
+                arg = ischop ? 512 : 0;
+               base = s - 1;
+                s++;                                /* skip the '0' first */
+                while (*s == '#')
+                    s++;
+                if (*s == '.') {
+                    char *f;
+                    s++;
+                    f = s;
+                    while (*s == '#')
+                        s++;
+                    arg |= 256 + (s - f);
+                }
+                *fpc++ = s - base;                /* fieldsize for FETCH */
+                *fpc++ = FF_0DECIMAL;
                *fpc++ = arg;
            }
            else {

diff --git a/t/op/write.t b/t/op/write.t
index 5b01eb7..fc155a8 100755 (executable)
--- a/t/op/write.t
+++ b/t/op/write.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..9\n";
+print "1..11\n";
 
 my $CAT = ($^O eq 'MSWin32') ? 'type' : 'cat';
 
@@ -43,7 +43,7 @@ of huma...
 now is the time for all good men to come to\n";
 
 if (`$CAT Op_write.tmp` eq $right)
-    { print "ok 1\n"; unlink 'Op_write.tmp'; }
+    { print "ok 1\n"; 1 while unlink 'Op_write.tmp'; }
 else
     { print "not ok 1\n"; }
 
@@ -85,7 +85,7 @@ necessary
 now is the time for all good men to come to\n";
 
 if (`$CAT Op_write.tmp` eq $right)
-    { print "ok 2\n"; unlink 'Op_write.tmp'; }
+    { print "ok 2\n"; 1 while unlink 'Op_write.tmp'; }
 else
     { print "not ok 2\n"; }
 
@@ -129,7 +129,7 @@ necessary
 now is the time for all good men to come to\n";
 
 if (`$CAT Op_write.tmp` eq $right)
-    { print "ok 3\n"; unlink 'Op_write.tmp'; }
+    { print "ok 3\n"; 1 while unlink 'Op_write.tmp'; }
 else
     { print "not ok 3\n"; }
 
@@ -184,7 +184,7 @@ $right =
 "fit\n";
 
 if (`$CAT Op_write.tmp` eq $right)
-    { print "ok 6\n"; unlink 'Op_write.tmp'; }
+    { print "ok 6\n"; 1 while unlink 'Op_write.tmp'; }
 else
     { print "not ok 6\n"; }
 
@@ -213,8 +213,53 @@ write (OUT4);
 close  OUT4;
 if (`$CAT Op_write.tmp` eq "1\n") {
     print "ok 9\n";
-    unlink "Op_write.tmp";
+    1 while unlink "Op_write.tmp";
     }
 else {
     print "not ok 9\n";
     }
+
+eval <<'EOFORMAT';
+format OUT10 =
+@####.## @0###.##
+$test1, $test1
+.
+EOFORMAT
+
+open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp";
+
+$test1 = 12.95;
+write(OUT10);
+close OUT10;
+
+$right = "   12.95 00012.95\n";
+if (`$CAT Op_write.tmp` eq $right)
+    { print "ok 10\n"; 1 while unlink 'Op_write.tmp'; }
+else
+    { print "not ok 10\n"; }
+
+eval <<'EOFORMAT';
+format OUT11 =
+@0###.## 
+$test1
+@ 0#
+$test1
+@0 # 
+$test1
+.
+EOFORMAT
+
+open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp";
+
+$test1 = 12.95;
+write(OUT11);
+close OUT11;
+
+$right = 
+"00012.95
+1 0#
+10 #\n";
+if (`$CAT Op_write.tmp` eq $right)
+    { print "ok 11\n"; 1 while unlink 'Op_write.tmp'; }
+else
+    { print "not ok 11\n"; }