"======================================================================
|
|   A pure Smalltalk class giving a full access to xBase (DBF) files.
|
|   $Revision: 1.7.5$
|   $Date: 2000/05/28 16:56:52$
|   $Author: pb$
|
 ======================================================================"


"======================================================================
|
| Written by Antonio d'Avino.
|
| This file is distributed together with GNU Smalltalk.
|
| GNU Smalltalk 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, or (at your option) any later version.
| 
| GNU Smalltalk 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
| GNU Smalltalk; see the file COPYING.  If not, write to the Free Software
| Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  
|
 ======================================================================"

Object subclass: #DBFile
    instanceVariableNames: 'filterArray lastUpdate setDelete records fileName fileStream headerSize recordSize currentRecord deleted updated headerUpdated eof bof fieldsInfos fieldsContents version '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Examples-Useful'!

DBFile comment: '
A pure Smalltalk class giving a full access to xBase (DBF) files.
By Antonio d''Avino - NAPLES (ITALY).
Fully compatible with CLIPPER(TM) 5.xx and DB III/IV (TM) Files.
V. 1.00  Feb 13, 1998. 
Please, feel free to post your messages to andavino@tin.it - criter@tin.it.

					NEXT STEPS
* Index management
* Visual xBase files maintenance tool'


!DBFile class methodsFor: 'Instance Creation'!

new: fileName
    "create a DBFile object open on an existing .DBF file named fileName.
     fileName may be a string or a symbol."
    ^(self basicNew setName: fileName asString) open.
!

new: fileName fields: fieldsDictionary

    "create a DBFile object creating a .DBF file named fileName.
    fileName may be a string or a symbol. 
    FieldsDictionary is a Dictionary whose key is the field name as string and
    the value an Array of 4 dimensions:
    - 1st position is a character indicating the field type
      ($C -> Character, $N Numeric, $L Logical, $D Date). 
    - 2nd  is field length. 
    - 3rd the field is decimal positions ( is not-significant if field is not Numeric).  
    - 4th position may be left nil"

    ^(self basicNew setName: fileName asString) create: fieldsDictionary.
! !


!DBFile class methodsFor: 'Class Testing'!

test 
    "A DBFile class test method"

    | a b |
    b := Dictionary new.
    Transcript showOnNewLine: 'Building new test xBase file ...'.
    b at: 'abc' put: (Array with: $C with: 5 with: 0 with: nil).
    a := DBFile new: #test fields: b.
    1 to: 10 do: [ : ix | a append;
		   	at: #abc put: (ix asString)
    ].
    Transcript show: ' Done'.
    Transcript showOnNewLine: 'Records in file ', ( a records asString).
    Transcript showOnNewLine: 'Setting filter on field ABC. Filter expression ''((db at: #abc) asNumber  == 2) not '' ...'.
    a compileFilter: '((db at: #abc) asNumber  == 2) not '.
    Transcript show: ' Done'.
    
    Transcript showOnNewLine: 'Start 1st test: Skipping forward from top ... '.
    a goTop.
  
    [ a eof or: [a bof]] whileFalse: [Transcript showOnNewLine: (a record asString), ' -- ', (a at: #abc) . a skip ].
    Transcript show: ' Done'.
    Transcript showOnNewLine: 'Start 2st test: Skipping backward from bottom ... '.
    a goBottom.
  
    [ a eof or: [a bof]] whileFalse: [Transcript showOnNewLine: (a record asString), ' -- ', (a at: #abc) . a skip: -1 ].
    Transcript show: ' Done'.
    Transcript showOnNewLine: 'Closing xBase test file and exiting ...' .
    a close.
    Transcript show: ' Done'.
! !


!DBFile methodsFor: 'Exiting'!

close
    " Close xDBase file flushing last updates and release object "
    updated ifTrue: [ self saveRecord ].
    headerUpdated ifTrue: [ self saveHeaderInfo ].
    fileStream close.
! !


!DBFile methodsFor: 'Testing'!

bof
    "test a beginning of file condition"
    ^bof
!

eof
    "test an end of file condition"
    ^eof!

isDBFFile

    "tests if the open file is a .DBF file (signature byte=03)"

    fileStream position: 0.
    ^(fileStream next asInteger = 3)
! !

!DBFile methodsFor: 'Testing'!

isDeleted
    "test a deleted condition for current record"
    ^deleted!

isUpdated

    " the currend record has been updated (return true) or not (return false) ?"
    ^updated!

version

    "answer current package version"

    ^ version! !


!DBFile methodsFor: 'Positioning'!
goBottom

    "set last record in file as current record. Deleted and Filter settings are influent"

    self goto: records;
	 skip: 0 direction: -1!

goto: rNumber

    "position file on record number rNumber. Deleted and Filter settings are NOT influent"

    | recordNumber |
     eof := false.
    bof := false.
    updated ifTrue: [ self saveRecord ].
    (rNumber<1) ifTrue: [recordNumber := 1. bof := true. ]
		ifFalse: [recordNumber := rNumber].
    (recordNumber<=records) ifTrue: [self gotoRecord: (currentRecord := recordNumber).
				     self getRecord.
				    ]
			    ifFalse: [ currentRecord := records+1.
				      eof := true.
				      self blankRecord.
				      deleted := false.
				    ]
!

goTop

    "set first record in file as current record. Deleted and Filter settings are influent"

    self goto: 1;
	 skip: 0 direction: 1!

skip

    "set next record in file as current record. Deleted and Filter settings are influent"
    ^self skip: 1 direction: 1!

skip: aNumber

    "jump to next aNumber record. Jump maybe forward (aNumber > 0) or backward (aNumber <0). Deleted and Filter settings are influent."

    self skip: aNumber direction: ((aNumber abs) / aNumber)! !


!DBFile methodsFor: 'Initializing'!

open
    "Open an existing .DBF file. This methods is called by class methods  new:  and 
    new:fields:. May be called directly to reopen a closed file"

    | file |
    self setVersion.
    (file := File name: fileName) exists
	ifFalse: [ ^self error: fileName, ': no such .DBF file' ]
	ifTrue: [ fileStream := file readStream.
		  self isDBFFile 
		    ifFalse: [ fileStream close.
			      ^ self error: fileName, ': is not a .DBF file' ]
		    ifTrue: [updated := false.
			    setDelete := false.
			    self getDBFInfos.
			    self goto: 1.
			    ^self
			    ].
		]
! !

!DBFile methodsFor: 'Accessing'!

append
    "append a new, blank record"

    updated ifTrue: [ self saveRecord ].
    (records > 0) ifTrue: [self gotoRecord: records.
			 fileStream skip: recordSize.
			]
		ifFalse: [fileStream position: headerSize].
    records := records+1.
    currentRecord := records.
    self blankRecord;
	 saveRecord.
    headerUpdated := true.
!

at: fieldName

  "answer current content of field. Field name maybe a string or a symbol. It returns nil if fieldName is not in file. fieldName is case insenitive"
  ^self unformatField: fieldName!

at: fieldName put: fieldValue

    " set field  fieldName value to fieldValue. Field name may be a string or a symbol. 
      fieldValue MUST be of the correct type for the field. The methods returns current
      field value or nil if fieldName is no in file. fieldName is case insensitive"

    | old  new |

    old := self unformatField: fieldName.
     new := self formatField: fieldName value: fieldValue.
    old isNil ifFalse: [ updated := true. fieldsContents at: (fieldName asString asUppercase) put: new ].
    ^old

delete

    "mark as deleted current record"

    deleted ifFalse: [ deleted := true. updated := true. ]
!

fieldDec: fieldName

    "returns  field decimal positions for field named fieldName     (string or symbol, case      insensitive). If field is not numeric this datum is not      significant and usually     zero. Method  returns nil if fieldName is not in file"

    | answ |
    answ := fieldsInfos at: (fieldName asString asUppercase) ifAbsent: [ nil ].
    ^ answ isNil ifTrue: [ nil ] ifFalse: [ answ at: 2 ]
!

fieldInfos: fieldName

    "returns an array three items sized, containing infos for field named fieldName		(string or symbol, case insensitive).. First array item is
     the field type, second the field length, third field decimal positions, fourth is
     the field offset inside record. Method     returns nil if fieldName is not in file"
    
    ^fieldsInfos at: (fieldName asString asUppercase) ifAbsent: [ nil ].
!

fieldInfosDictionary

    "returns the field infos dictionary. Any key in dictionary is a field name, value      is an array four items sized, containing field infos. . First array item is
     the field type, second the field length, third field decimal positions, fourth is
    the field offset inside record."
    
    ^fieldsInfos .
!

fieldLen: fieldName
    "returns field length for field named fieldName (string or
     symbol, case insensitive). Method returns nil if fieldName is not in file"
    | answ |
    answ := fieldsInfos at: (fieldName asString asUppercase) ifAbsent: [ nil ].
    ^ answ isNil ifTrue: [ nil ] ifFalse: [ answ at: 2 ]
!

fieldType: fieldName

    "returns a character describing field type for field named fieldName (string or
     symbol, case insensitive). Character $C stands for Character field, $N for 
     Numeric field, $L for logical field, $D for date field. Returns nil if fieldName
     is not in file"
    | answ |
    answ := fieldsInfos at: (fieldName asString asUppercase) ifAbsent: [ nil ].
    ^ answ isNil ifTrue: [ nil ] ifFalse: [ answ at: 1 ]
!

record

    "return current record number"
    ^currentRecord
!

records

    "return records in file"
    ^records!

restore

    "unmark as deleted current record"
    deleted ifTrue: [deleted := false.updated := true]! !


!DBFile methodsFor: 'Private'!

blankRecord

    "put empty contents into field contents collection"
    
    | tp k val |

    updated := false.
    fieldsInfos associationsDo: [ : a  | tp := a value at: 1.
			  k := a key.
			      (tp==$C) ifTrue: [val := self formatField: k value: ''].
			 (tp==$N) ifTrue: [val := self formatField: k value: 0].
			 (tp==$L) ifTrue: [val := false].
			 (tp==$D) ifTrue: [val := self formatField: k value: (Date newDay: 1 month: 1 year: 1)].
			 fieldsContents at: k put: val ].
!

char2Num: aString
    "converts hex num in aString to integer"
    
    | aNum ix |

    aNum := 0.
     ix := 1.
       aString do: [ : a | aNum := aNum + ((a  asInteger) * ix). ix := ix*256].
       ^aNum!

create: fDictionary

    | pos  ky file |
    self setVersion.
    file := File name: fileName.
    file exists ifTrue: [ file remove ].
    fileStream :=  file writeStream.
    lastUpdate := Date today.
    records := 0.
    currentRecord := 0.
    updated := false.
    headerUpdated := false.
    deleted := false.
    setDelete := false.
    pos := 1.
    fieldsContents := Dictionary new.
    fieldsInfos := Dictionary new.
    fDictionary associationsDo: [ : a |  ky := a key asString asUppercase. 
				      ky := ky copyFrom: 1 to: (10 min: (ky size)).
				      (a value) at: 4 put: pos.  
				      fieldsInfos at: ky put: a value.
				      pos := pos+((a value) at:  2).
			       ].
    recordSize := pos.
    headerSize := 34+((fieldsInfos size) * 32).
    self createHeaderInfo
!

createHeaderInfo

    "save .DBF file header info's"
     
    headerUpdated := false.
    fileStream     position: 0;
		    nextPut: (Character value: 3);
		nextPut: ((self num2Char: ((lastUpdate year) - 1900) size: 1) at: 1);
		nextPut: ((self num2Char: (lastUpdate monthIndex) size: 1) at: 1);
		nextPut: ((self num2Char: (lastUpdate dayOfMonth - 1900) size: 1) at: 1);
		nextPutAll: (self num2Char: records size: 4);
		nextPutAll: (self num2Char: headerSize size: 2);
		 nextPutAll: (self num2Char: recordSize size: 2).
    self saveFieldsInfos.
    fileStream nextPut: (Character value: 13);
		nextPut: (Character value: 0);
		nextPut: (Character value: 26).
!

evaluateFilters

    | answ |
    answ := true.
    ^filterArray allSatisfy: [ :a | a value: self ]
!

formatField: fieldName value: v

    |  answ k  t l d  i dc is dcs cti sgn comma tmp |
    k := fieldName asString asUppercase.
    t := (fieldsInfos at: k ifAbsent: [ ^ nil ]) at: 1.
    l := (fieldsInfos at: k ) at: 2.
    d := (fieldsInfos at: k ) at: 3.
			 (t == $N) ifTrue: [     i := v asInteger.
					    is := i abs asString.
					    sgn := (i<0) ifTrue: ['-'] ifFalse: [''].
						     comma := (d>0) ifTrue: ['.'] ifFalse: [''].
						     cti := ((tmp := (l - d - (is size) - (sgn size) - (comma size))) > 0) ifTrue: [String new: tmp withAll:'0'] ifFalse: [''].
					    (d>0) ifTrue:
					    [    dc := (v - i) abs.
						dcs := dc asFloat asString.
						dcs := ((dcs copyFrom: 3 to: dcs size), (String new: d withAll: $0)) copyFrom: 1 to: d.
					    ]
					    ifFalse: [ dcs := ''].
					    answ := (sgn,cti,is,comma,dcs).
					    answ := answ copyFrom: ((answ size) - l + 1) to: (answ size)					 ].
			 (t == $L) ifTrue: [answ := v ifTrue: [$T] ifFalse: [$F] ].
			 (t == $D) ifTrue: [ answ := v year asString.
					   tmp := '0',(v monthIndex asString).
					   tmp := tmp copyFrom: (tmp size - 1) to: tmp size.
					   answ := answ,tmp.
					   tmp := '0',(v day asString).
					   tmp := tmp copyFrom: (tmp size - 1) to: tmp size.
					   answ := answ,tmp.
					].
			(t == $C) ifTrue: [ answ := (v, (String new: l withAll: $  )) copyFrom: 1 to: l].
^ answ
!

getDBFInfos
    "get all infos about open DBF file"

    self  getHeaderInfo;
	 getFieldsInfos.
    fieldsContents := Dictionary new.
    ^self!

getFieldsInfos

    "get field infos on fieldsInfos array"

     | pos name type len dec fpos  |

    pos := 32.
     fieldsInfos := Dictionary new.
     fpos := 1.
     [ pos < (headerSize - 2)] whileTrue: [fileStream position: pos. name := (fileStream upTo: 0 asCharacter). 
					fileStream position: pos+11. type := fileStream next.
					fileStream skip: 4.
					dec := 0.
					( type == $C ) ifTrue:  [len := self char2Num: (fileStream next: 2)]
						      ifFalse:  [len := self char2Num: (fileStream next) asString.
								dec := self char2Num: (fileStream next) asString.
							       ].
					fieldsInfos at: name put: (Array with: type with: len with: dec with: fpos).
					fpos := fpos+len.
					 pos := pos+32.
					   ].
!

getHeaderInfo
    "get .DBF file header info's"
     | d m y |
    headerUpdated := false.
    fileStream position: 1.
     y := (self char2Num: (fileStream next) asString).
     m := (self char2Num: (fileStream next) asString).
     d := (self char2Num: (fileStream next) asString).

     lastUpdate := Date newDay: d month: m year: y.
     records := self char2Num: (fileStream next: 4).
     headerSize := self char2Num: (fileStream next: 2).
     recordSize := self char2Num: (fileStream next: 2).
!

getRecord

    "get current record contents"

    | tmp str k v |

    tmp := fileStream next: recordSize.
    str := ReadStream on: tmp from: 1 to: recordSize.
    ((tmp at: 1) == $  ) ifFalse: [ deleted := true ]
		       ifTrue: [ deleted := false ].
    fieldsInfos associationsDo: [ : a |  k := a key.
				  v := a value.
				  str position: (v at: 4).
				  fieldsContents at: k  put: (str next: (v at: 2)).
			    ].					    
		updated := false.!

gotoRecord: recordNumber
    
    "position currentRecord to recordNumber"
     
    ((recordNumber <= records) and: [ recordNumber>0]) ifFalse: [ self error: 'Record number outside file bounds' ]
			       ifTrue: [ fileStream position: headerSize+(((currentRecord := recordNumber) - 1) * recordSize)].
	     !

newBlock: source
    | result |
    self class compile: source.
    result := self XXXBLOCK.
    self class removeSelector: #XXXBLOCK.
    ^result
!

num2Char: aNum size: aSize

    "converts aNum hex num to aString"
    
    | tmp answ |

     answ :=  String new: aSize withAll: $  .
     tmp := aNum.
	1 to: aSize do: [ : ix |  answ at: ix put: (Character value: (tmp \\ 256)).			     tmp := tmp//256 ].
       ^answ!

saveFieldsInfos

    "get field infos on fieldsInfos array"

     | pos  |

    pos := 32.
    fileStream position: 32.
     fieldsInfos associationsDo: [ : a |fileStream     position: pos; 
						     nextPutAll: ((a key asUppercase), (Character value:0) asString);
						position: pos+11;
						nextPut: ((a value) at: 1);
						skip: 4.
						(((a value) at: 1) == $C) ifTrue:
						    [  fileStream nextPutAll: (self num2Char: ((a value) at: 2) size:2) ]
									ifFalse:
						    [ fileStream nextPut: ((self num2Char: ((a value) at: 2) size:1) at: 1);
								 nextPut: ((self num2Char: ((a value) at: 3) size:1) at: 1)
						    ].
						pos := pos+32.
					   ].
				       fileStream position: pos.!

saveHeaderInfo

    "save .DBF file header info's"
     
    headerUpdated := false.
    fileStream position: 4;
	       nextPutAll: (self num2Char: records size: 4).
!

saveRecord

    | str tmp |
    
    self gotoRecord: currentRecord.
    tmp := String new: recordSize withAll: $ .
    deleted ifTrue: [tmp at: 1 put: $* ].
     str := WriteStream on: tmp from: 1 to: recordSize.
    fieldsContents associationsDo: [ : a | str position: ((fieldsInfos at: (a key)) at: 4).
					str nextPutAll: (fieldsContents at: a key).
					].
    fileStream nextPutAll: tmp.
     updated := false.!

setName: aString
     "Set the .DBF file name to aString"
    | ext |

    ext := ''.
    (aString includesSubstring: '.' caseSensitive: true)    ifFalse: [ ext := '.DBF' ].
    fileName := (aString, ext)
!

setVersion

    version := 'DBFile Class Package V. 1.00 by Antonio d''Avino andavino@tin.it'!

skip: aNumber direction: ofs

    self goto: (currentRecord + aNumber).
    [(((filterArray isNil not and: [self evaluateFilters]) or: [setDelete and: [deleted]]) and: [ eof not]) and: [bof not]] whileTrue: 
		[self goto: currentRecord + ofs ].!

unformatField: fieldName

    |  k  t answ str1 y m dy |
    k := fieldName asString asUppercase.
    t := (fieldsInfos at: k ifAbsent: [ ^ nil ]) at: 1.
			  (t == $N) ifTrue: [ answ := (fieldsContents at: k) asNumber ].
			 (t == $L) ifTrue: [(answ := (fieldsContents at: k) == $T) ].
			 (t == $D) ifTrue: [ str1 := ReadStream on: (fieldsContents at: k) from: 1 to: 8.
					   y := ( str1 next: 4) asInteger.
					   m := ( str1 next: 2) asInteger.
					   dy := (str1 next: 2) asInteger.
					   answ := Date newDay: dy month: m year: y.
					].
			(t == $C) ifTrue: [ answ := fieldsContents at: k ].
^ answ

! !


!DBFile methodsFor: 'Settings'!

noFilter

    "remove any filter setting for file"
    filterArray := nil!

setDeleted

    "inquiry the deleted record filtering status"
    ^setDelete!

setDeleted: status

    "set (status == true) or reset (status == false) deleted record filter status"

    setDelete := status!

setFilter: aBlock
    "set a new filter condition. Any preceding filter condition is lost. aBlock must be a
     one-parameter Smalltalk block, returning  a true or false value. If returned value
     is true record is acceptd, if false record is rejected. Current dbFile object may
     be referred in the first parameter. See 'test' class method for a sample of using
     setFilter message"

    filterArray := OrderedCollection with: aBlock.
!

setFilterAdditive: aBlock

    "Append a new filter condition. Filter conditions are chained by a logical AND. See
     remark of setFilter method for a description of aBlock format"

    filterArray isNil ifTrue: [filterArray := OrderedCollection new].
    filterArray add: aBlock
!

compileFilter: code

    "set a new filter condition. Any preceding filter condition is lost. code must be a
     string describing a Smalltalk block, returning  a true or false value. If returned 
     value is true record is acceptd, if false record is rejected. Current dbFile object may 
     be referred in code as 'db'. See 'test' class method for a sample of using 
     compileFilter message"

    filterArray := OrderedCollection new.
    filterArray add: (self newBlock: 'XXXBLOCK ^[ :db | ',(code asString), ']').!

compileFilterAdditive: code

    "Append a new filter condition. Filter conditions are chained by a logical AND. See
     remark of compileFilter method for a description of aBlock format"

    filterArray isNil ifTrue: [filterArray := OrderedCollection new].
    filterArray add: (self newBlock: 'XXXBLOCK ^[ :db | ',(code asString), ']').
! !
