1 package File
::Rsync
::Mirror
::Recentfile
::FakeBigFloat
;
5 use Data
::Float
qw(nextup);
13 sub _bigfloatmax
($$);
14 sub _bigfloatmin
($$);
15 sub _increase_a_bit
($;$);
16 sub _increase_a_bit_tail
($$);
17 sub _my_sprintf_float
($);
23 File::Rsync::Mirror::Recentfile::FakeBigFloat - pseudo bigfloat support
27 use version
; our $VERSION = qv
('0.0.5');
30 use base
qw(Exporter);
42 $EXPORT_TAGS{all
} = \
@EXPORT_OK;
46 use File::Rsync::Mirror::Recentfile::FakeBigFloat qw(:all);
48 =head1 ONLY INTERNAL FUNCTIONS
50 These functions are not part of a public interface and can be
51 changed and go away any time without prior notice.
55 We treat strings that look like floating point numbers. If the native
56 floating point support is good enough we use it. If it isn't we make
57 sure no two unequal numbers are treated the same and vice versa. Only
58 comparison operators are supported, no other math.
62 All functions are exported in the C<:all> tag.
64 =head2 _bigfloatcmp ( $l, $r )
66 Cmp function for floating point numbers that have a larger significand
67 than can be handled by native perl floats.
70 sub _bigfloatcmp
($$) {
72 unless (defined $_[0] and defined $_[1]) {
75 $_ = defined $_ ?
$_ : "UNDEF";
77 Carp
::confess
("_bigfloatcmp called with l[$_[0]]r[$_[1]]: but both must be defined");
79 # unequal is much more frequent than equal but let's get rid of these
80 return 0 if $_[0] eq $_[1];
81 my $can_rely_on_native = 0;
82 if ($_[0] =~ /\./ || $_[1] =~ /\./) {
83 # if one is a float, both must be, otherwise perl gets it wrong (see test)
85 $_ .= ".0" unless /\./;
87 return 1 if $_[0] - $_[1] > 1;
88 return -1 if $_[0] - $_[1] < -1;
90 $can_rely_on_native = 1; # can we?
92 #### XXX bug in some perls, we cannot trust native comparison on floating point values:
93 #### see Todo file entry on 2009-03-15
94 my $native = $_[0] <=> $_[1];
95 return $native if $can_rely_on_native && $native != 0;
96 $_[0] =~ s/^/0/ while index($_[0],".") < index($_[1],".");
97 $_[1] =~ s/^/0/ while index($_[1],".") < index($_[0],".");
101 =head2 _bigfloatge ( $l, $r )
106 sub _bigfloatge
($$) {
107 _bigfloatcmp
($_[0],$_[1]) >= 0;
110 =head2 _bigfloatgt ( $l, $r )
115 sub _bigfloatgt
($$) {
116 _bigfloatcmp
($_[0],$_[1]) > 0;
119 =head2 _bigfloatle ( $l, $r )
124 sub _bigfloatle
($$) {
125 _bigfloatcmp
($_[0],$_[1]) <= 0;
128 =head2 _bigfloatlt ( $l, $r )
133 sub _bigfloatlt
($$) {
134 _bigfloatcmp
($_[0],$_[1]) < 0;
137 =head2 _bigfloatmax ( $l, $r )
139 Same for max (of two arguments)
142 sub _bigfloatmax
($$) {
144 return _bigfloatcmp
($l,$r) >= 0 ?
$l : $r;
147 =head2 _bigfloatmin ( $l, $r )
149 Same for min (of two arguments)
152 sub _bigfloatmin
($$) {
154 return _bigfloatcmp
($l,$r) <= 0 ?
$l : $r;
157 =head2 $big = _increase_a_bit ( $l, $r )
159 =head2 $big = _increase_a_bit ( $n )
161 The first form calculates a string that is between the two numbers,
162 closer to $l to prevent rounding effects towards $r. The second form
163 calculates the second number itself based on nextup() in
167 sub _my_sprintf_float
($) {
171 my $nvsize = $Config::Config
{nvsize
} || 8;
172 my $lom = 2*$nvsize; # "length of mantissa": nextup needs more digits
173 NORMALIZE
: while () {
174 my $sprintf = "%." . $lom . "f";
175 $r = sprintf $sprintf, $x;
176 if ($r =~ /\.\d+0$/) {
185 sub _increase_a_bit
($;$) {
187 unless (defined $l) {
188 die "Alert: _increase_a_bit called with undefined first argument";
192 die "Alert: _increase_a_bit called with identical arguments";
195 $r = _my_sprintf_float
(Data
::Float
::nextup
($l));
201 my $try = _my_sprintf_float
((3*$l+$r)/4);
202 if (_bigfloatlt
($l,$try) && _bigfloatlt
($try,$r) ) {
207 return _increase_a_bit_tail
($l,$r);
209 sub _increase_a_bit_tail
($$) {
213 $_ .= ".0" unless /\./;
215 $l =~ s/^/0/ while index($l,".") < index($r,".");
216 $r =~ s/^/0/ while index($r,".") < index($l,".");
217 $l .= "0" while length($l) < length($r);
218 $r .= "0" while length($r) < length($l);
220 DIG
: for (my $i = 0; $i < length($l); $i++) {
221 if (substr($l,$i,1) ne substr($r,$i,1)) {
226 $ret = substr($l,0,$diffdigit);
227 my $sl = substr($l,$diffdigit); # significant l
228 my $sr = substr($r,$diffdigit);
233 my $srlength = length $sr;
234 my $srmantissa = $srlength - index($sr,".");
235 # we want 1+$srlength because if l ends in 99999 and r in 00000,
236 # we need one digit more
237 my $fformat = sprintf "%%0%d.%df", 1+$srlength, $srmantissa;
238 my $appe = sprintf $fformat, (3*$sl+$sr)/4;
239 $appe =~ s/(\d)0+$/$1/;
245 my $try = substr($ret,0,length($ret)-1);
246 if (_bigfloatlt
($l,$try) && _bigfloatlt
($try,$r)) {
255 =head1 COPYRIGHT & LICENSE
257 Copyright 2008, 2009 Andreas König.
259 This program is free software; you can redistribute it and/or modify it
260 under the same terms as Perl itself.
264 1; # End of File::Rsync::Mirror::Recentfile
268 # cperl-indent-level: 4