lib/File/Rsync/Mirror/Recentfile/FakeBigFloat.pm

   1 package File::Rsync::Mirror::Recentfile::FakeBigFloat;
   2
   3 # use warnings;
   4 use strict;
   5 use Data::Float qw(nextup);
   6
   7 # _bigfloat
   8 sub _bigfloatcmp ($$);
   9 sub _bigfloatge ($$);
  10 sub _bigfloatgt ($$);
  11 sub _bigfloatle ($$);
  12 sub _bigfloatlt ($$);
  13 sub _bigfloatmax ($$);
  14 sub _bigfloatmin ($$);
  15 sub _increase_a_bit ($;$);
  16 sub _increase_a_bit_tail ($$);
  17 sub _my_sprintf_float ($);
  18
  19 =encoding utf-8
  20
  21 =head1 NAME
  22
  23 File::Rsync::Mirror::Recentfile::FakeBigFloat - pseudo bigfloat support
  24
  25 =cut
  26
  27 use version; our $VERSION = qv('0.0.1');
  28
  29 use Exporter;
  30 use base qw(Exporter);
  31 our %EXPORT_TAGS;
  32 our @EXPORT_OK = qw(
  33                     _bigfloatcmp
  34                     _bigfloatge
  35                     _bigfloatgt
  36                     _bigfloatle
  37                     _bigfloatlt
  38                     _bigfloatmax
  39                     _bigfloatmin
  40                     _increase_a_bit
  41                    );
  42 $EXPORT_TAGS{all} = \@EXPORT_OK;
  43
  44 =head1 SYNOPSIS
  45
  46   use File::Rsync::Mirror::Recentfile::FakeBigFloat qw(:all);
  47
  48 =head1 ONLY INTERNAL FUNCTIONS
  49
  50 These functions are not part of a public interface and can be
  51 changed and go away any time without prior notice.
  52
  53 =head1 DESCRIPTION
  54
  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.
  59
  60 =head1 EXPORT
  61
  62 All functions are exported in the C<:all> tag.
  63
  64 =head2 _bigfloatcmp ( $l, $r )
  65
  66 Cmp function for floating point numbers that have a larger significand
  67 than can be handled by native perl floats.
  68
  69 =cut
  70 sub _bigfloatcmp ($$) {
  71     # my($l,$r) = @_;
  72     unless (defined $_[0] and defined $_[1]) {
  73         require Carp;
  74         for ($_[0],$_[1]) {
  75             $_ = defined $_ ? $_ : "UNDEF";
  76         }
  77         Carp::confess("_bigfloatcmp called with l[$_[0]]r[$_[1]]: but both must be defined");
  78     }
  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)
  84         for ($_[0], $_[1]){
  85             $_ .= ".0" unless /\./;
  86         }
  87         return  1 if $_[0] -  $_[1] >  1;
  88         return -1 if $_[0] -  $_[1] < -1;
  89     } else {
  90         $can_rely_on_native = 1; # can we?
  91     }
  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],".");
  98     $_[0] cmp $_[1];
  99 }
 100
 101 =head2 _bigfloatge ( $l, $r )
 102
 103 Same for ge
 104
 105 =cut
 106 sub _bigfloatge ($$) {
 107     _bigfloatcmp($_[0],$_[1]) >= 0;
 108 }
 109
 110 =head2 _bigfloatgt ( $l, $r )
 111
 112 Same for gt
 113
 114 =cut
 115 sub _bigfloatgt ($$) {
 116     _bigfloatcmp($_[0],$_[1]) > 0;
 117 }
 118
 119 =head2 _bigfloatle ( $l, $r )
 120
 121 Same for lt
 122
 123 =cut
 124 sub _bigfloatle ($$) {
 125     _bigfloatcmp($_[0],$_[1]) <= 0;
 126 }
 127
 128 =head2 _bigfloatlt ( $l, $r )
 129
 130 Same for lt
 131
 132 =cut
 133 sub _bigfloatlt ($$) {
 134     _bigfloatcmp($_[0],$_[1]) < 0;
 135 }
 136
 137 =head2 _bigfloatmax ( $l, $r )
 138
 139 Same for max (of two arguments)
 140
 141 =cut
 142 sub _bigfloatmax ($$) {
 143     my($l,$r) = @_;
 144     return _bigfloatcmp($l,$r) >= 0 ? $l : $r;
 145 }
 146
 147 =head2 _bigfloatmin ( $l, $r )
 148
 149 Same for min (of two arguments)
 150
 151 =cut
 152 sub _bigfloatmin ($$) {
 153     my($l,$r) = @_;
 154     return _bigfloatcmp($l,$r) <= 0 ? $l : $r;
 155 }
 156
 157 =head2 $big = _increase_a_bit ( $l, $r )
 158
 159 =head2 $big = _increase_a_bit ( $n )
 160
 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
 164 L<Data::Float>.
 165
 166 =cut
 167 sub _my_sprintf_float ($) {
 168     my($x) = @_;
 169     my $r;
 170     require Config;
 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$/) {
 177             last NORMALIZE;
 178         } else {
 179             $lom *= 2;
 180         }
 181     }
 182     $r =~ s/(\d)0+$/$1/;
 183     return $r;
 184 }
 185 sub _increase_a_bit ($;$) {
 186     my($l,$r) = @_;
 187     unless (defined $l) {
 188         die "Alert: _increase_a_bit called with undefined first argument";
 189     }
 190     if (defined $r){
 191         if ($r eq $l){
 192             die "Alert: _increase_a_bit called with identical arguments";
 193         }
 194     } else {
 195         $r = _my_sprintf_float(Data::Float::nextup($l));
 196     }
 197     my $ret;
 198     if ($l == $r) {
 199     } else {
 200         # native try
 201         my $try = _my_sprintf_float((3*$l+$r)/4);
 202         if (_bigfloatlt($l,$try) && _bigfloatlt($try,$r) ) {
 203             $ret = $try;
 204         }
 205     }
 206     return $ret if $ret;
 207     return _increase_a_bit_tail($l,$r);
 208 }
 209 sub _increase_a_bit_tail ($$) {
 210     my($l,$r) = @_;
 211     my $ret;
 212     for ($l, $r){
 213         $_ .= ".0" unless /\./;
 214     }
 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);
 219     my $diffdigit;
 220   DIG: for (my $i = 0; $i < length($l); $i++) {
 221         if (substr($l,$i,1) ne substr($r,$i,1)) {
 222             $diffdigit = $i;
 223             last DIG;
 224         }
 225     }
 226     $ret = substr($l,0,$diffdigit);
 227     my $sl = substr($l,$diffdigit); # significant l
 228     my $sr = substr($r,$diffdigit);
 229     if ($ret =~ /\./) {
 230         $sl .= ".0";
 231         $sr .= ".0";
 232     }
 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/;
 240     if ($ret =~ /\./) {
 241         $appe =~ s/\.//;
 242     }
 243     $ret .= $appe;
 244   CHOP: while () {
 245         my $try = substr($ret,0,length($ret)-1);
 246         if (_bigfloatlt($l,$try) && _bigfloatlt($try,$r)) {
 247             $ret = $try;
 248         } else {
 249             last CHOP;
 250         }
 251     }
 252     return $ret;
 253 }
 254
 255 =head1 COPYRIGHT & LICENSE
 256
 257 Copyright 2008, 2009 Andreas König.
 258
 259 This program is free software; you can redistribute it and/or modify it
 260 under the same terms as Perl itself.
 261
 262 =cut
 263
 264 1; # End of File::Rsync::Mirror::Recentfile
 265
 266 # Local Variables:
 267 # mode: cperl
 268 # cperl-indent-level: 4
 269 # End: