# utils.tcl --
#
#	Utility routines for data definition
#
# Copyright (c) 1996 - 1997, William Byrne
#
# See the file "license.txt" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

package provide TslcBDE_utils 1.0

namespace eval TslcBDE {

	namespace export DataSetInfo DropFields AddField AddIndex \
    	AddValChk AddRef MetaData

	proc GenRule { len {ch =}} {
		append r $ch $ch $ch $ch
       	set rule {}
		set len [expr $len / [string length $r]]
		for { set x 0 } { $x < $len } { incr x } {
			append rule $r
		}
		return $rule
	}

	proc _DataSetInfo { Obj {Channel stdout} } {
		if {$Channel == {}} { set Channel stdout }
		puts $Channel ""
		puts $Channel [format "Table Information :%s: %s " [$Obj info databaseName] [$Obj info tableName]]
		set fmt "%-15.15s %-6.6s %-8.8s %-8.8s %-6.6s %-6.6s %-4.4s %-8.8s %-8.8s %-5.5s %-5.5s %-5.5s %-7.7s %-10.10s"
		set hdr [format $fmt "Field Name" Number Type SubType Units1 Units2 Null Vchk Rights Req'd Min Max Default Picture]
		set na {---}
		puts $Channel $hdr
		puts $Channel [GenRule [string length $hdr]]

		set c [$Obj FldDesc Count]
		set v [$Obj ValDesc Count]
		for { set i 0 } { $i < $c } { incr i } {
			set nam [$Obj FldDesc $i Name]
			set num [$Obj FldDesc $i FldNum ]
			set typ [$Obj FldDesc $i FldType]
			set sub [$Obj FldDesc $i SubType]
			set un1 [$Obj FldDesc $i Units1]
			set un2 [$Obj FldDesc $i Units2]
			set nul [$Obj FldDesc $i NullOffset]
			set vck [$Obj FldDesc $i Vchk]
			set rgt [$Obj FldDesc $i Rights]

			for { set j 0 } { $j < $v } { incr j } {
				if { [$Obj ValDesc $j FldNum] == [expr $i + 1] } {
					set req [$Obj ValDesc $j Req]
					set min [$Obj ValDesc $j Min]
					set max [$Obj ValDesc $j Max]
					set def [$Obj ValDesc $j Def]
					set pic [$Obj ValDesc $j Pict]
					break;
				}
			}
			if { $j >= $v } {
				set req $na
				set min $na
				set max $na
				set def $na
				set pic $na
			}

			puts $Channel [format $fmt $nam $num $typ $sub $un1 $un2 $nul $vck $rgt $req $min $max $def $pic]
		}
		puts $Channel ""
		set fmt "%-25.25s %-8.8s %-8.8s %-8.8s %-8.8s %s"
		set hdr [format $fmt "Index Name" Primary Unique Maint Desc Fields]
		puts $Channel $hdr
		puts $Channel [GenRule [expr [string length $hdr] + 15]]
		set c [$Obj IdxDesc Count]
		for { set i 0 } { $i < $c } { incr i } {
			set flds {}
			set k [$Obj IdxDesc $i FldsInKey]
			for { set n 0 } { $n < $k } { incr n } {
				if { $flds != {} } {
					append flds ";"
				}
				append flds [$Obj FldDesc [expr [$Obj IdxDesc $i KeyFld $n] - 1] Name]
			}
			set nam [$Obj IdxDesc $i Name]
			if { $nam == {} } { set nam (none) }
			set pri [$Obj IdxDesc $i Primary]
			set uni [$Obj IdxDesc $i Unique]
			set mnt [$Obj IdxDesc $i Maint]
			set des [$Obj IdxDesc $i Desc]
			puts $Channel [format $fmt $nam $pri $uni $mnt $des $flds]
		}
	}

	proc BDE2IB { type subtype size } {
    	switch $type {
        	Int32		-
        	UInt32		{ return "INTEGER" }
            Int16		-
            UInt16		{ return "SMALLINT" }
            ZString		{ return [format "VARCHAR(%d)" $size] }
            Bool		{ return "INTEGER" }
            Float64     -
            Float80		{ return "DOUBLE PRECISION" }
            Date		-
            DateTime	{ return "DATE" }
            Blob		{
	            			if { $subtype == "Memo" } {
    	        				return "BLOB SUB_TYPE TEXT"
        	                } else {
            	            	return "BLOB"
                	        }
                        }
            default		{ return "UNKNOWN" }
        }
	}
}

proc ::TslcBDE::DataSetInfo { Obj {Channel stdout}} {
	set f [$Obj Bool False]
	set t [$Obj Bool True]
	$Obj Bool False False
	$Obj Bool True True
	set err [catch { _DataSetInfo $Obj $Channel } errMsg]
	$Obj Bool False $f
	$Obj Bool True $t
	if $err {error $errMsg}
}

proc ::TslcBDE::DropFields { Obj ATable AFldList } {
	$Obj FldDesc Serialize; # Renumber FLDDesc.iFldNum from 1 to n; may be PDox idents

	set c [llength $AFldList]; # llength is Tcl Internal Command - count of AFldList elements
	for { set x 0 } { $x < $c } { incr x } {
		$Obj FldDesc [lindex $AFldList $x] Op Drop
	}

	$Obj FldDesc Purge; # Remove FLDDesc's tagged as Drop
}

proc ::TslcBDE::AddField { Obj AName AType ASubType AUnits1 AUnits2 } {
	set i [$Obj FldDesc Add]; # returns the index of new FldDesc
	$Obj FldDesc $i Name $AName
	$Obj FldDesc $i FldType $AType
	if { $ASubType != "" } {
		$Obj FldDesc $i SubType $ASubType
	}
	$Obj FldDesc $i Units1 $AUnits1
	$Obj FldDesc $i Units2 $AUnits2
	$Obj FldDesc $i Op Add
	return $i
}

proc ::TslcBDE::AddValChk { Obj AFldNum AReq bMin bMax bDef AMin AMax ADef APict } {
	set i [$Obj ValDesc Add]
	$Obj ValDesc $i FldNum $AFldNum
	$Obj ValDesc $i Required $AReq
	if { $bMin } { $Obj ValDesc $i Min $AMin }
	if { $bMax } { $Obj ValDesc $i Max $AMax }
	if { $bDef } { $Obj ValDesc $i Def $ADef }
	$Obj ValDesc $i Pict $APict
	$Obj ValDesc $i Op Add
	return $i
}

proc ::TslcBDE::AddIndex { Obj APrimary AMaint AUnique ADesc AName AFldList } {
	set i [$Obj IdxDesc Add]
	$Obj IdxDesc $i Primary $APrimary
	$Obj IdxDesc $i Maint $AMaint
	$Obj IdxDesc $i Unique $AUnique
	$Obj IdxDesc $i Name $AName
	$Obj IdxDesc $i Desc $ADesc
	set c [llength $AFldList]; # llength is Tcl Internal Command - count of AFldList elements
	$Obj IdxDesc $i FldsInKey $c; # A limit should be checked here!
	for { set x 0 } { $x < $c } { incr x } {
		$Obj IdxDesc $i KeyFld $x [lindex $AFldList $x]; #lindex returns x element from list
	}
	$Obj IdxDesc $i Op Add
	return $i
}

proc ::TslcBDE::AddRef { Obj AName AType AOthTbl AModOp ADelOp  AThisFldList AOthFldList } {
#	Make sure that an index exists for this tables fields
	set i [$Obj RefDesc Add]
	$Obj RefDesc $i Num [expr $i + 1]
	$Obj RefDesc $i Name $AName
	$Obj RefDesc $i Type $AType
	$Obj RefDesc $i TblName $AOthTbl
	$Obj RefDesc $i ModOp $AModOp
	$Obj RefDesc $i DelOp $ADelOp
	set c [llength $AThisFldList]
	$Obj RefDesc $i FldCount $c
	for { set x 0 } { $x < $c } { incr x } {
		$Obj RefDesc $i ThisTblFld $x [lindex $AThisFldList $x]
		$Obj RefDesc $i OthTblFld $x [lindex $AOthFldList $x]
	}
	$Obj RefDesc $i Op Add
	return $i
}

proc ::TslcBDE::MetaData { Obj {ch stdout}} {
	
	if {$ch == {}} { set ch stdout }
	set fmt " %s %s%s"
	set comma ","

	$Obj FldDesc Serialize; # Make sure fields are numbered 1-n; PDox field idents

# -------- Evaluate Primary Key --------------
	set c [$Obj IdxDesc Count]
	set priFlds ""
	for { set i 0 } { $i < $c } { incr i } {
		if { [$Obj IdxDesc $i Primary]  } {
			set k [$Obj IdxDesc $i FldsInKey]
			for { set j 0 } { $j < $k } { incr j } {
				if { $priFlds == "" } {
					set priFlds [$Obj FldDesc [expr [$Obj IdxDesc $i KeyFld $j] - 1] Name]
				} else {
					set priFlds [format " %s, %s" $priFlds [$Obj FldDesc [expr [$Obj IdxDesc $i KeyFld $j] - 1] Name]]
				}
			}
			break;
		}
	}


# -------- Evaluate Foreign Keys ------------
	set c [$Obj RefDesc Count]
	set fk 0
	set foreign { }
	if { $c > 0 } { Table fkTable }
	catch {
	for { set i 0 } { $i < $c } { incr i } {
		if { [$Obj RefDesc $i Type] == "Master" } { continue }
		incr fk
		set xTable [$Obj RefDesc $i TblName]
		fkTable Open -desc $xTable
		set flds ""
		set k [$Obj RefDesc Count]
		for { set j 0 } { $j < $k } { incr j } {
			if { $j == 0 } {
				set flds [$Obj FldDesc [expr [$Obj RefDesc $i ThisTblFld $j] - 1] Name]
			} else {
				set flds [format " %s, %s" $flds [$Obj FldDesc [expr [$Obj RefDesc $i ThisTblFld $j] - 1] Name]]
			}
		}
		set xflds ""
		for { set j 0 } { $j < $k } { incr j } {
			if { $j == 0 } {
				set xflds [fkTable FldDesc [expr [$Obj RefDesc $i OthTblFld $j] - 1] Name]
			} else {
				set xflds [format " %s, %s" $xflds [fkTable FldDesc [expr [$Obj RefDesc $i OthTblFld $j] - 1] Name]]
			}
		}
		set xTable [file rootname [file tail $xTable]]
		lappend foreign [format " FOREIGN KEY ( %s ) REFERENCES %s ( %s )" $flds $xTable $xflds]
	}
	} errMsg
	if { $c > 0 } { fkTable Free }
	if { $errMsg != "" } { error $errMsg }

# -------- Print Header --------------
	puts $ch [format "CREATE TABLE %s (" [file rootname [file tail [$Obj Info TableName]]]]

# -------- Print Fields --------------
	set c [$Obj FldDesc Count]
	for { set i 0 } { $i < $c } { incr i } {
		set nam [$Obj FldDesc $i Name]
		set typ [BDE2IB [$Obj FldDesc $i FldType] [$Obj FldDesc $i SubType] [$Obj FldDesc $i Units1]]
		if { $i == $c - 1 && $priFlds == "" && $fk == 0 } { set comma "" }
		puts $ch [format $fmt $nam $typ $comma]
	}

# -------- Print Primary Key --------------
	if { $priFlds != "" } {
		if { $fk == 0 } { set comma "" }
		puts $ch [format " PRIMARY KEY ( %s )%s" $priFlds $comma]
	}

#--------- Print Foreign Keys -------------
	for { set i 0 } { $i < $fk } { incr i } {
		if { $i == [expr $fk - 1] } { set comma "" }
		puts $ch [format "%s%s" [lindex $foreign $i] $comma]
	}

# -------- Print Close Paren --------------
	puts $ch ");"
}


# --- EOF ---

