Zero-padded Numerics in Perl Format

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

p4raw-id: //depot/perl@7444

4 files changed, 112 insertions, 6 deletions

diff --git a/form.h b/form.h
index ca2a0c8433..4c08bbde8a 100644
--- 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 95dd6c5164..72a2904bca 100644
--- 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 a65cb1b4b6..729a438f32 100644
--- 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 5b01eb78b7..fc155a88c7 100755
--- 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"; }