# Database fixed point number API.
# Rick Smereka, Copyright (C) 2006

# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.

# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.

# You should have received a copy of the GNU General Public License
# along with this program; if not, get a copy via the Internet at
# http://gnu.org/copyleft/gpl.html or write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA

# You can contact the author via email at rsmereka@future-lab.com

# This module contains functions that support read and write of
# database fields which contain fixed point numbers. The numbers
# are stored in database fields without the decimal point. You
# must know where the decimal point belongs. Anytime this module
# is used the fixed-point math API ('fxp') must also be 'source'ed
# into your program.

# Initial tcl version Mar/2006, Rick Smereka

proc dbfxp_get {tid field_no sc fxp_list_out} {
   # Obtain field contents from the 'tid' table, field 'field_no'.
   # The field contents will be used to create a fixed-point
   # number ('fxp') with the decimal located in the 'sc'
   # position (from the right). Returns a 'dbeng'
   # code with an 'fxp list' load into 'fxp_list_out' upon success.
   global DBENG_OK DBENG_NO_SUCH_TID DBENG_INVALID_FUNCTION
   global DBENG_INTERNAL_ERROR
   upvar $fxp_list_out ufxp_list_out
   set ufxp_list_out ""
   set mname "dbfxp_get"

   logman "$mname:enter"

   if {![dbeng_atid_lookup $tid]} {
      db_io_code_log $mname "exit:bad tid" $DBENG_NO_SUCH_TID
      return $DBENG_NO_SUCH_TID
   }

   if {![num $field_no]} {
      db_io_code_log $mname "non-numeric(field_no)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {$field_no <= 0} {
      db_io_code_log $mname "out of range(field_no)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {![num $sc]} {
      db_io_code_log $mname "non-numeric(sc)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {$sc < 0} {
      db_io_code_log $mname "out of range(sc)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   # get the field contents and validate
   set field ""
   set ret [db_get_field $tid $field_no field]

   if {$ret != $DBENG_OK} {
      db_io_code_log $mname "bad rc from db_get_field(field)" $ret
      return $ret
   }

   if {![num $field]} {
      db_io_code_log $mname "non-numeric(field)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   set result [fxp_iconv $field]

   if {$result == ""} {
      db_io_code_log $mname "bad rc from fxp_iconv(field)" $DBENG_INTERNAL_ERROR
      return $DBENG_INTERNAL_ERROR
   }

   # separate result list into component parts
   set ret [fxp_get_list $result out_fxp out_scale]

   if {!$ret} {
      db_io_code_log $mname "bad rc from fxp_get_list(result)" \
                     $DBENG_INTERNAL_ERROR
      return $DBENG_INTERNAL_ERROR
   }

   # set scale to specified and build output list
   set ufxp_list_out [list $out_fxp $sc]
   db_io_code_log $mname "normal exit" $DBENG_OK
   return $DBENG_OK
}

proc dbfxp_put {tid field_no sc fxp_list} {
   # Write a fixed-point number to a database field. The number
   # will be written without a decimal point (if any). The
   # number will have its scale adjusted (position of the
   # decimal point) to 'sc'. The caller must know the scale.
   # A database write will not take place after writing the
   # field contents. The field number may be zero indicating an
   # append to the record. Returns a 'dbeng' code.
   global DBENG_OK DBENG_NO_SUCH_TID DBENG_INVALID_FUNCTION
   global DBENG_INTERNAL ERROR
   set mname "dbfxp_put"

   logman "$mname:enter"

   if {![dbeng_atid_lookup $tid]} {
      db_io_code_log $mname "exit:bad tid" $DBENG_NO_SUCH_TID
      return $DBENG_NO_SUCH_TID
   }

   if {![num $field_no]} {
      db_io_code_log $mname "non-numeric(field_no)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {$field_no < 0} {
      db_io_code_log $mname "out of range(field_no)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {![num $sc]} {
      db_io_code_log $mname "non-numeric(sc)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {$sc < 0} {
      db_io_code_log $mname "out of range(scale)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   # perform output conversion on fxp list
   set ret [fxp_oconv $fxp_list $sc result]

   if {!$ret} {
      db_io_code_log $mname "bad rc from fxp_oconv(fxp_list)" \
                     $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   # copy to final output eliminating decimal point
   set result2 [fxp_remove_decimal $result]

   if {$result2 == ""} {
      db_io_code_log $mname "bad rc(empty) from fxp_remove_decimal(result)" \
                     $DBENG_INTERNAL_ERROR
      return $DBENG_INTERNAL_ERROR
   }

   set ret [db_put_field $tid $field_no $result2]

   if {$ret != $DBENG_OK} {
      db_io_code_log $mname "bad rc from db_put_field(result2)" $ret
      return $ret
   }

   db_io_code_log $mname "normal exit" $DBENG_OK
   return $DBENG_OK
}

proc dbfxp_get_subfield {tid field_no subfield_no sc fxp_list_out} {
   # Obtain subfield contents from the 'tid' table, field 'field_no'
   # and subfield 'subfield_no'. The subfield contents will be used
   # to create a fixed-point number ('fxp') with the decimal located
   # in the 'sc' position (from the right). Returns a 'dbeng'
   # code with an 'fxp list' loaded into 'fxp_list_out' upon success.
   # the subfield contents must be a number (0-9,-) without any decimal
   # point.
   global DBENG_OK DBENG_NO_SUCH_TID DBENG_INVALID_FUNCTION
   global DBENG_INTERNAL_ERROR
   upvar $fxp_list_out ufxp_list_out
   set ufxp_list_out ""
   set mname "dbfxp_get_subfield"

   logman "$mname:enter"

   if {![dbeng_atid_lookup $tid]} {
      db_io_code_log $mname "exit:bad tid" $DBENG_NO_SUCH_TID
      return $DBENG_NO_SUCH_TID
   }

   if {![num $field_no]} {
      db_io_code_log $mname "non-numeric(field_no)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {$field_no <= 0} {
      db_io_code_log $mname "out of range(field_no)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {![num $subfield_no]} {
      db_io_code_log $mname "non-numeric(subfield_no)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {$subfield_no <= 0} {
      db_io_code_log $mname "out of range(subfield_no)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {![num $sc]} {
      db_io_code_log $mname "non-numeric(sc)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {$sc < 0} {
      db_io_code_log $mname "out of range(sc)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   # get the subfield contents and validate
   set subfield ""
   set ret [db_get_subfield $tid $field_no $subfield_no subfield]

   if {$ret != $DBENG_OK} {
      db_io_code_log $mname "bad rc from db_get_field(subfield)" $ret
      return $ret
   }

   if {![num $subfield]} {
      db_io_code_log $mname "non-numeric(subfield)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   set result [fxp_iconv $subfield]

   if {$result == ""} {
      db_io_code_log $mname "bad rc from fxp_iconv(subfield)" \
                     $DBENG_INTERNAL_ERROR
      return $DBENG_INTERNAL_ERROR
   }

   # separate result list into component parts
   set ret [fxp_get_list $result out_fxp out_scale]

   if {!$ret} {
      db_io_code_log $mname "bad rc from fxp_get_list(result)" \
                     $DBENG_INTERNAL_ERROR
      return $DBENG_INTERNAL_ERROR
   }

   # set scale to specified and build output list
   set ufxp_list_out [list $out_fxp $sc]
   db_io_code_log $mname "normal exit" $DBENG_OK
   return $DBENG_OK
}

proc dbfxp_put_subfield {tid field_no subfield_no sc fxp_list} {
   # Write a fixed-point number to a database subfield. The number
   # will be written without a decimal point (if any). The
   # number will have its scale adjusted (position of the
   # decimal point) to 'sc'. The caller must know the scale.
   # A database write will not take place after writing the
   # field contents. The field number or subfield number
   # may be zero indicating an append to the record. Returns a 'dbeng' code.
   global DBENG_OK DBENG_NO_SUCH_TID DBENG_INVALID_FUNCTION
   global DBENG_INTERNAL ERROR
   set mname "dbfxp_put_subfield"

   logman "$mname:enter"

   if {![dbeng_atid_lookup $tid]} {
      db_io_code_log $mname "exit:bad tid" $DBENG_NO_SUCH_TID
      return $DBENG_NO_SUCH_TID
   }

   if {![num $field_no]} {
      db_io_code_log $mname "non-numeric(field_no)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {$field_no < 0} {
      db_io_code_log $mname "out of range(field_no)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {![num $subfield_no]} {
      db_io_code_log $mname "non-numeric(subfield_no)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {$subfield_no < 0} {
      db_io_code_log $mname "out of range(subfield_no)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {![num $sc]} {
      db_io_code_log $mname "non-numeric(sc)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {$sc < 0} {
      db_io_code_log $mname "out of range(scale)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   # perform output conversion on fxp list
   set ret [fxp_oconv $fxp_list $sc result]

   if {!$ret} {
      db_io_code_log $mname "bad rc from fxp_oconv(fxp_list)" \
                     $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   # copy to final output eliminating decimal point
   set result2 [fxp_remove_decimal $result]

   if {$result2 == ""} {
      db_io_code_log $mname "bad rc(empty) from fxp_remove_decimal(result)" \
                     $DBENG_INTERNAL_ERROR
      return $DBENG_INTERNAL_ERROR
   }

   set ret [db_put_subfield $tid $field_no $subfield_no $result2]

   if {$ret != $DBENG_OK} {
      db_io_code_log $mname "bad rc from db_put_subfield(result2)" $ret
      return $ret
   }

   db_io_code_log $mname "normal exit" $DBENG_OK
   return $DBENG_OK
}

proc dbfxp_get_subsubfield {tid field_no sf ssf sc fxp_list_out} {
   # Obtain subsubfield contents from the 'tid' table, field 'field_no',
   # subfield 'sf' and the subsubfield 'ssf'. The subsubfield contents 
   # will be used to create a fixed-point number ('fxp') with the 
   # decimal located in the 'sc' position (from the right). Returns a 'dbeng'
   # code with an 'fxp list' loaded into 'fxp_list_out' upon success.
   # The subsubfield contents must be a number (0-9,-) without any decimal
   # point.
   global DBENG_OK DBENG_NO_SUCH_TID DBENG_INVALID_FUNCTION
   global DBENG_INTERNAL_ERROR
   upvar $fxp_list_out ufxp_list_out
   set ufxp_list_out ""
   set mname "dbfxp_get_subsubfield"

   logman "$mname:enter"

   if {![dbeng_atid_lookup $tid]} {
      db_io_code_log $mname "exit:bad tid" $DBENG_NO_SUCH_TID
      return $DBENG_NO_SUCH_TID
   }

   if {![num $field_no]} {
      db_io_code_log $mname "non-numeric(field_no)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {$field_no <= 0} {
      db_io_code_log $mname "out of range(field_no)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {![num $sf]} {
      db_io_code_log $mname "non-numeric(sf)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {$sf <= 0} {
      db_io_code_log $mname "out of range(sf)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {![num $ssf]} {
      db_io_code_log $mname "non-numeric(ssf)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {$ssf <= 0} {
      db_io_code_log $mname "out of range(ssf)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {![num $sc]} {
      db_io_code_log $mname "non-numeric(sc)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {$sc < 0} {
      db_io_code_log $mname "out of range(sc)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   # get the subfield contents and validate
   set subsubfield ""
   set ret [db_get_subsubfield $tid $field_no $sf $ssf subsubfield]

   if {$ret != $DBENG_OK} {
      db_io_code_log $mname "bad rc from db_get_subsubfield(subsubfield)" $ret
      return $ret
   }

   if {![num $subsubfield]} {
      db_io_code_log $mname "non-numeric(subsubfield)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   set result [fxp_iconv $subsubfield]

   if {$result == ""} {
      db_io_code_log $mname "bad rc from fxp_iconv(subsubfield)" \
                     $DBENG_INTERNAL_ERROR
      return $DBENG_INTERNAL_ERROR
   }

   # separate result list into component parts
   set ret [fxp_get_list $result out_fxp out_scale]

   if {!$ret} {
      db_io_code_log $mname "bad rc from fxp_get_list(result)" \
                     $DBENG_INTERNAL_ERROR
      return $DBENG_INTERNAL_ERROR
   }

   # set scale to specified and build output list
   set ufxp_list_out [list $out_fxp $sc]
   db_io_code_log $mname "normal exit" $DBENG_OK
   return $DBENG_OK
}

proc dbfxp_put_subsubfield {tid field_no sf ssf sc fxp_list} {
   # Write a fixed-point number to a database subsubfield. The number
   # will be written without a decimal point (if any). The
   # number will have its scale adjusted (position of the
   # decimal point) to 'sc'. The caller must know the scale.
   # A database write will not take place after writing the
   # field contents. The field number, subfield number or subsubfield number
   # may be zero indicating an append to the record. Returns a 'dbeng' code.
   global DBENG_OK DBENG_NO_SUCH_TID DBENG_INVALID_FUNCTION
   global DBENG_INTERNAL ERROR
   set mname "dbfxp_put_subsubfield"

   logman "$mname:enter"

   if {![dbeng_atid_lookup $tid]} {
      db_io_code_log $mname "exit:bad tid" $DBENG_NO_SUCH_TID
      return $DBENG_NO_SUCH_TID
   }

   if {![num $field_no]} {
      db_io_code_log $mname "non-numeric(field_no)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {$field_no < 0} {
      db_io_code_log $mname "out of range(field_no)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {![num $sf]} {
      db_io_code_log $mname "non-numeric(sf)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {$sf < 0} {
      db_io_code_log $mname "out of range(sf)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {![num $ssf]} {
      db_io_code_log $mname "non-numeric(ssf)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {$ssf < 0} {
      db_io_code_log $mname "out of range(ssf)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }
   if {![num $sc]} {
      db_io_code_log $mname "non-numeric(sc)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   if {$sc < 0} {
      db_io_code_log $mname "out of range(scale)" $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   # perform output conversion on fxp list
   set ret [fxp_oconv $fxp_list $sc result]

   if {!$ret} {
      db_io_code_log $mname "bad rc from fxp_oconv(fxp_list)" \
                     $DBENG_INVALID_FUNCTION
      return $DBENG_INVALID_FUNCTION
   }

   # copy to final output eliminating decimal point
   set result2 [fxp_remove_decimal $result]

   if {$result2 == ""} {
      db_io_code_log $mname "bad rc(empty) from fxp_remove_decimal(result)" \
                     $DBENG_INTERNAL_ERROR
      return $DBENG_INTERNAL_ERROR
   }

   set ret [db_put_subsubfield $tid $field_no $sf $ssf $result2]

   if {$ret != $DBENG_OK} {
      db_io_code_log $mname "bad rc from db_put_subsubfield(result2)" $ret
      return $ret
   }

   db_io_code_log $mname "normal exit" $DBENG_OK
   return $DBENG_OK
}
