Small optimisations, by Brandon Black
[p5sagit/p5-mst-13.2.git] / t / op / sprintf2.t
CommitLineData
1d917b39 1#!./perl -w
2
3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
6 require './test.pl';
7}
8
9911cee9 9plan tests => 1292;
1d917b39 10
11is(
12 sprintf("%.40g ",0.01),
13 sprintf("%.40g", 0.01)." ",
14 q(the sprintf "%.<number>g" optimization)
15);
16is(
17 sprintf("%.40f ",0.01),
18 sprintf("%.40f", 0.01)." ",
19 q(the sprintf "%.<number>f" optimization)
20);
cc61b222 21
22# cases of $i > 1 are against [perl #39126]
23for my $i (1, 5, 10, 20, 50, 100) {
24 chop(my $utf8_format = "%-*s\x{100}");
25 my $string = "\xB4"x$i; # latin1 ACUTE or ebcdic COPYRIGHT
26 my $expect = $string." "x$i; # followed by 2*$i spaces
27 is(sprintf($utf8_format, 3*$i, $string), $expect,
28 "width calculation under utf8 upgrade, length=$i");
6c94ec8b 29}
fc7325bb 30
59b61096 31# check simultaneous width & precision with wide characters
32for my $i (1, 3, 5, 10) {
33 my $string = "\x{0410}"x($i+10); # cyrillic capital A
34 my $expect = "\x{0410}"x$i; # cut down to exactly $i characters
35 my $format = "%$i.${i}s";
36 is(sprintf($format, $string), $expect,
37 "width & precision interplay with utf8 strings, length=$i");
38}
39
fc7325bb 40# Used to mangle PL_sv_undef
41fresh_perl_is(
42 'print sprintf "xxx%n\n"; print undef',
43 'Modification of a read-only value attempted at - line 1.',
44 { switches => [ '-w' ] },
45 q(%n should not be able to modify read-only constants),
863811b2 46);
47
2fba7546 48# check overflows
45e52d63 49for (int(~0/2+1), ~0, "9999999999999999999") {
2fba7546 50 is(eval {sprintf "%${_}d", 0}, undef, "no sprintf result expected %${_}d");
51 like($@, qr/^Integer overflow in format string for sprintf /, "overflow in sprintf");
52 is(eval {printf "%${_}d\n", 0}, undef, "no printf result expected %${_}d");
53 like($@, qr/^Integer overflow in format string for prtf /, "overflow in printf");
54}
863811b2 55
2fba7546 56# check %NNN$ for range bounds
863811b2 57{
58 my ($warn, $bad) = (0,0);
59 local $SIG{__WARN__} = sub {
60 if ($_[0] =~ /uninitialized/) {
61 $warn++
62 }
63 else {
64 $bad++
65 }
66 };
2fba7546 67
45e52d63 68 my $fmt = join('', map("%$_\$s%" . ((1 << 31)-$_) . '$s', 1..20));
2fba7546 69 my $result = sprintf $fmt, qw(a b c d);
70 is($result, "abcd", "only four valid values in $fmt");
863811b2 71 is($warn, 36, "expected warnings");
72 is($bad, 0, "unexpected warnings");
73}
74
343ef749 75{
76 foreach my $ord (0 .. 255) {
77 my $bad = 0;
78 local $SIG{__WARN__} = sub {
79 if ($_[0] !~ /^Invalid conversion in sprintf/) {
80 warn $_[0];
81 $bad++;
82 }
83 };
84 my $r = eval {sprintf '%v' . chr $ord};
85 is ($bad, 0, "pattern '%v' . chr $ord");
86 }
87}
9911cee9 88
89sub mysprintf_int_flags {
90 my ($fmt, $num) = @_;
91 die "wrong format $fmt" if $fmt !~ /^%([-+ 0]+)([1-9][0-9]*)d\z/;
92 my $flag = $1;
93 my $width = $2;
94 my $sign = $num < 0 ? '-' :
95 $flag =~ /\+/ ? '+' :
96 $flag =~ /\ / ? ' ' :
97 '';
98 my $abs = abs($num);
99 my $padlen = $width - length($sign.$abs);
100 return
101 $flag =~ /0/ && $flag !~ /-/ # do zero padding
102 ? $sign . '0' x $padlen . $abs
103 : $flag =~ /-/ # left or right
104 ? $sign . $abs . ' ' x $padlen
105 : ' ' x $padlen . $sign . $abs;
106}
107
108# Whole tests for "%4d" with 2 to 4 flags;
109# total counts: 3 * (4**2 + 4**3 + 4**4) == 1008
110
111my @flags = ("-", "+", " ", "0");
112for my $num (0, -1, 1) {
113 for my $f1 (@flags) {
114 for my $f2 (@flags) {
115 for my $f3 ('', @flags) { # '' for doubled flags
116 my $flag = $f1.$f2.$f3;
117 my $width = 4;
118 my $fmt = '%'."${flag}${width}d";
119 my $result = sprintf($fmt, $num);
120 my $expect = mysprintf_int_flags($fmt, $num);
121 is($result, $expect, qq/sprintf("$fmt",$num)/);
122
123 next if $f3 eq '';
124
125 for my $f4 (@flags) { # quadrupled flags
126 my $flag = $f1.$f2.$f3.$f4;
127 my $fmt = '%'."${flag}${width}d";
128 my $result = sprintf($fmt, $num);
129 my $expect = mysprintf_int_flags($fmt, $num);
130 is($result, $expect, qq/sprintf("$fmt",$num)/);
131 }
132 }
133 }
134 }
135}
136