# File I/O function library module,
# Rick Smereka, Copyright (C) 2005.

# 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

# Initial tcl version. Mar/2005, Rick Smereka

# sequential counter for 'unique'
set fio_fcount 0

proc unique {dir fname} {
   # Create a unique file name. Uniquness will be tested in the
   # directory 'dir'. Do not end 'dir' with a path separator.
   # 'dir' can be an empty string which will indicate the current
   # directory. The unique file name is returned in 'fname'
   # upon success. Returns 1 upon success, 0 otherwise.
   upvar $fname lk
   global fio_fcount
   set len [string length $dir]
   set lk ""

   if {$len} {
      set ch [string index $dir end]
      
      if {$ch == "/"} {
         return 0
      }

      if {![isdirectory $dir]} {
         return 0
      }
   }

   set ex 1

   while {$ex} {
      if {$fio_fcount > 99999999} {
         set fio_fcount 0
      }

      set rname [lpad $fio_fcount "0" 8].tmp
      incr fio_fcount
      
      if {$len} {
         set total_f $dir/$rname
      } else {
         set total_f $rname
      }

      set ex [exist $total_f]
   }

   set lk $rname
   return 1
}

proc exist {fname} {
   # Test for file existance. Returns 1 if the file exists,
   # 0 otherwise.
   if {![string length $fname]} {
      return 0
   }

   return [file readable $fname]
}

proc numrecs {fi} {
   # Count the number of records in a file. The file is assumed to be
   # already open. Returns the number of records upon success, 0
   # otherwise.
   set numrec 0

   if {[catch {seek $fi 0}]} {
      return $numrec
   }

   set buf [get_rec $fi]

   while {![eof $fi]} {
      incr numrec
      set buf [get_rec $fi]
   }

   seek $fi 0
   return $numrec
}

proc get_nrec {recno fi} {
   # Read the 'recno' record from 'fi'. Returns the record contents
   # upon success, an empty string otherwise.
   set line ""

   if {[catch {seek $fi 0}]} {
      return $line
   }

   for {set i 0} {$i < $recno} {incr i} {
      set ret [gets $fi line]

      if {[eof $fi]} {
         set line ""
         return $line
      }
   }

   return $line
}

proc get_rec {fi} {
   # Read a record from 'fi'. Returns the line upon success, an
   # empty string otherwise.
   set line ""

   catch {
      set ret [gets $fi line]
   }

   return $line
}

proc zcreate {fname} {
   # Create a zero byte file called 'fname'. It is an error if the
   # file already exists. Returns 1 upon success, 0 otherwise.
   if {![string length $fname]} {
      return 0
   }

   if {[exist $fname]} {
      return 0
   }

   if {[catch {open $fname w} fid]} {
      return 0
   }

   close $fid
   return 1
}

proc isdirectory {path} {
   # Check for 'path' being a directory. Not strictly required but
   # provided for compatibility with 'C' source. Returns 1 if 'path'
   # is a directory, 0 otherwise.
   return [file isdirectory $path]
}

proc filecopy {src dest} {
   # Copy a file from 'src' to 'dest'. If 'dest' file
   # exists, it will be overwritten. Returns 1 upon
   # success, 0 otherwise. Not strictly required but
   # provided for compatibility with 'C' source.
   if {[catch {file copy -force $src $dest}]} {
      return 0
   }

   return 1
}

proc qrename {src dest} {
   # Rename a file anywhere. Returns 1 upon success, 0 otherwise.
   # The destination file must not already exist.
   # Not strictly necessary since it appears that tcl's rename will
   # move from one filesystem to another. Provided for compatibility
   # with 'C' source.
   if {[catch {file rename $src $dest}]} {
      return 0
   }

   return 1
}

# Since tcl provides input and output line delimiter translation
# in channels via the 'fconfigure' command, the routines
# 'write_dos_line' and 'write_unix_line' do not seem required.
