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 nextdown);
   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.
  58
  59 =head1 EXPORT
  60
  61 All functions are exported in the C<:all> tag.
  62
  63 =head2 _bigfloatcmp ( $l, $r )
  64
  65 Cmp function for floating point numbers that have a longer
  66 mantissa than can be handled by native perl floats.
  67
  68 =cut
  69 sub _bigfloatcmp ($$) {
  70     my($l,$r) = @_;
  71     if ($l =~ /\./ || $r =~ /\./) {
  72         # if one is a float, both must be, otherwise perl gets it wrong (see test)
  73         for ($l, $r){
  74             $_ .= ".0" unless /\./;
  75         }
  76     }
  77     my $native = $l <=> $r;
  78     return $native if $native;
  79     $l =~ s/^/0/ while index($l,".") < index($r,".");
  80     $r =~ s/^/0/ while index($r,".") < index($l,".");
  81     $l cmp $r;
  82 }
  83
  84 =head2 _bigfloatge ( $l, $r )
  85
  86 Same for ge
  87
  88 =cut
  89 sub _bigfloatge ($$) {
  90     my($l,$r) = @_;
  91     _bigfloatcmp($l,$r) >= 0;
  92 }
  93
  94 =head2 _bigfloatgt ( $l, $r )
  95
  96 Same for gt
  97
  98 =cut
  99 sub _bigfloatgt ($$) {
 100     my($l,$r) = @_;
 101     _bigfloatcmp($l,$r) > 0;
 102 }
 103
 104 =head2 _bigfloatle ( $l, $r )
 105
 106 Same for lt
 107
 108 =cut
 109 sub _bigfloatle ($$) {
 110     my($l,$r) = @_;
 111     _bigfloatcmp($l,$r) <= 0;
 112 }
 113
 114 =head2 _bigfloatlt ( $l, $r )
 115
 116 Same for lt
 117
 118 =cut
 119 sub _bigfloatlt ($$) {
 120     my($l,$r) = @_;
 121     _bigfloatcmp($l,$r) < 0;
 122 }
 123
 124 =head2 _bigfloatmax ( $l, $r )
 125
 126 Same for max (of two arguments)
 127
 128 =cut
 129 sub _bigfloatmax ($$) {
 130     my($l,$r) = @_;
 131     return _bigfloatcmp($l,$r) >= 0 ? $l : $r;
 132 }
 133
 134 =head2 _bigfloatmin ( $l, $r )
 135
 136 Same for min (of two arguments)
 137
 138 =cut
 139 sub _bigfloatmin ($$) {
 140     my($l,$r) = @_;
 141     return _bigfloatcmp($l,$r) <= 0 ? $l : $r;
 142 }
 143
 144 =head2 _increase_a_bit ( $l, $r )
 145
 146 =head2 _increase_a_bit ( $n )
 147
 148 The first form calculates a string that is between the two numbers,
 149 closer to $l to prevent rounding effects towards $r. The second form
 150 calculates the second number itself based on the current architecture
 151 and L<Data::Float::nextup()>.
 152
 153 Note: there is a %.128f hard coded that needs to be fixed
 154
 155 =cut
 156 sub _my_sprintf_float ($) {
 157     my($x) = @_;
 158     my $r = sprintf "%.128f", $x;
 159     $r =~ s/(\d)0+$/$1/;
 160     return $r;
 161 }
 162 sub _increase_a_bit ($;$) {
 163     my($l,$r) = @_;
 164     unless (defined $l) {
 165         die "Alert: _increase_a_bit called with undefined first argument";
 166     }
 167     if (defined $r){
 168         if ($r eq $l){
 169             die "Alert: _increase_a_bit called with identical arguments";
 170         }
 171     } else {
 172         $r = _my_sprintf_float(Data::Float::nextup($l));
 173     }
 174     my $ret;
 175     if ($l == $r) {
 176     } else {
 177         # native try
 178         my $try = _my_sprintf_float((3*$l+$r)/4);
 179         if (_bigfloatlt($l,$try) && _bigfloatlt($try,$r) ) {
 180             $ret = $try;
 181         }
 182     }
 183     return $ret if $ret;
 184     return _increase_a_bit_tail($l,$r);
 185 }
 186 sub _increase_a_bit_tail ($$) {
 187     my($l,$r) = @_;
 188     my $ret;
 189     for ($l, $r){
 190         $_ .= ".0" unless /\./;
 191     }
 192     $l =~ s/^/0/ while index($l,".") < index($r,".");
 193     $r =~ s/^/0/ while index($r,".") < index($l,".");
 194     $l .= "0" while length($l) < length($r);
 195     $r .= "0" while length($r) < length($l);
 196     my $diffdigit;
 197   DIG: for (my $i = 0; $i < length($l); $i++) {
 198         if (substr($l,$i,1) ne substr($r,$i,1)) {
 199             $diffdigit = $i;
 200             last DIG;
 201         }
 202     }
 203     $ret = substr($l,0,$diffdigit);
 204     my $sl = substr($l,$diffdigit); # significant l
 205     my $sr = substr($r,$diffdigit);
 206     if ($ret =~ /\./) {
 207         $sl .= ".0";
 208         $sr .= ".0";
 209     }
 210     my $srlength = length $sr;
 211     my $srmantissa = $srlength - index($sr,".");
 212     # we want 1+$srlength because if l ends in 99999 and r in 00000,
 213     # we need one digit more
 214     my $fformat = sprintf "%%0%d.%df", 1+$srlength, $srmantissa;
 215     my $appe = sprintf $fformat, (3*$sl+$sr)/4;
 216     $appe =~ s/(\d)0+$/$1/;
 217     if ($ret =~ /\./) {
 218         $appe =~ s/\.//;
 219     }
 220     $ret .= $appe;
 221   CHOP: while () {
 222         my $try = substr($ret,0,length($ret)-1);
 223         if (_bigfloatlt($l,$try) && _bigfloatlt($try,$r)) {
 224             $ret = $try;
 225         } else {
 226             last CHOP;
 227         }
 228     }
 229     return $ret;
 230 }
 231
 232 =head1 COPYRIGHT & LICENSE
 233
 234 Copyright 2008 Andreas König.
 235
 236 This program is free software; you can redistribute it and/or modify it
 237 under the same terms as Perl itself.
 238
 239 =cut
 240
 241 1; # End of File::Rsync::Mirror::Recentfile
 242
 243 # Local Variables:
 244 # mode: cperl
 245 # cperl-indent-level: 4
 246 # End: