1#!./perl -w 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require './test.pl'; 7} 8 9plan tests => 1292; 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); 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"); 29} 30 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 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), 46); 47 48# check overflows 49for (int(~0/2+1), ~0, "9999999999999999999") { 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} 55 56# check %NNN$ for range bounds 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 }; 67 68 my $fmt = join('', map("%$_\$s%" . ((1 << 31)-$_) . '$s', 1..20)); 69 my $result = sprintf $fmt, qw(a b c d); 70 is($result, "abcd", "only four valid values in $fmt"); 71 is($warn, 36, "expected warnings"); 72 is($bad, 0, "unexpected warnings"); 73} 74 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} 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 137