# Convert from a Cobol signed decimal number.
# Tolkin based this on the code in perl module COBOLIO.pm
# written by Harry Holt [hholt@vec.state.va.us] .
# See http://www.lizardslounge.org/cobolio.html
# This works on the signed decimal type, which the module
# designates using the value of '+'.
# This should NOT be used for ordinary numbers!
#
# I added code to remove leading zeroes.  But I do this at the very
# end.  It might be better to integrate it into the existing code.
#
# I reuse his variable names, e.g. retVal and ActualLen,
# to reduce the number of changes from the original code.
# However I use $decimals for $FD{$fdRec}{$dataItemName}->{DECIMALS}.
#
sub convert_from_cobol_signed_decimal {
    my $retVal = shift;
    # We force caller to provide this next argument
    my $decimals = shift;
    if (! (defined $decimals)) {
        warn "Bug: Not enough arguments to convert_from_cobol_signed_decimal\n";
        $rc = 1;
        die; # this is a Fatal error
    }
    my $actualLen = length($retVal);
    
    $retVal =~ s/ /0/g; 
    $retVal =~ s/\x00/0/g;
    if (substr($retVal,$actualLen - 1,1) eq "{") {
        $retVal = substr($retVal,0,$actualLen - 1)."0";
    } else {
        if (substr($retVal,$actualLen - 1,1) eq "}") {
            $retVal = '-'.substr($retVal,0,$actualLen - 1)."0";
        } else {
            if ($retVal =~ m/[A-I]/) {
                $retVal =~ tr/[ABCDEFGHI]/[123456789]/;
            }
            if ($retVal =~ m/[J-R]/) {
                $retVal =~ tr/[JKLMNOPQR]/[123456789]/;
                $retVal = '-'.$retVal;
            }
        }
    }

    if($decimals > 0) {
        $retVal = substr($retVal,0,length($retVal) - $decimals).
            ".".substr($retVal,length($retVal) - $decimals);
    }	# End of DECIMAL logic

    # Tolkin added -- remove leading zeroes.
    # But do NOT remove the zero just in front of the decimal point,
    # for numbers < 1 and > -1  -- we want this  in the canonical
    # form for XML decimal type.
    # We use a separate test for whether it is negative
    # to keep the pattern matching a little simpler.
    # 
    my $is_negative = 0; 
    if ($retVal =~ s/^[-]//) {
        $is_negative = 1;
    }
    if ($retVal =~ s/^0+//) { # remove all leading zeroes
        # ensure there is a digit to the left of the (implied) decimal point
        if ($retVal eq '' || $retVal =~ /^[.]/) { 
            $retVal = '0' . $retVal;
        }
    }
    if ($is_negative) {
        $retVal = '-' . $retVal;
    }
    
    return $retVal;
}