Wiki Home

GenDbc Lite


Namespace: DotNet
**********************************
* Program GenDbcLt
* Generates just the CREATE TABLE commands, not all the other stuff.

* lDbc( "d:\vfe6\sample\data\sample.dbc", .t. )
lDir( "d:\temp", .f. )

return
**********************************
function lDbc( tcDbc, tlDta )

Local ;
	lnTbls
	
Local array ;
	laTbls
	
close database
open database (tcDbc)

lInit( tcDbc )

? "create database " + juststem( tcDbc )
?

lnTbls = ADBOBJECTS( laTbls, "Table" )

lTbls( laTbls, "STRUCTURE" )
lRels()
lVues()

IF tlDta	
	lTbls( "DATA" )
endif

lDone()

return
**********************************
Function lDir( tcDir, tlData )

lcDir = Addbs( tcDir )

Set Path to (lcDir)

lcOutName = lcDir + laPaths(alines( laPaths, lcDir, .t., "\" ))
lInit( lcOutName )

lnTbls = ADir( laTbls, lcDir + "*.dbf" )
* just want the fieldnames
Create Cursor fNames ( cFname c(60) )
Append From array laTbls
Release laTbls
Copy To array laTbls

lTbls( @laTbls, "STRUCTURE" )

IF tlData	
	lTbls( "DATA" )
endif

lDone()

return
**********************************
function lInit( tcOutNam )

local lcOutNam

clear
set memowidth to 2000

lcOutNam = ForceExt( tcOutNam, 'prg' )

set alternate to ( lcOutNam )
set alternate on

? "* " + lcOutNam 
? "* Generated " + ttoc( datetime() )
?

return
**********************************
function ldone()

local ;
	lcPrg
	
lcPrg = set("alternate",1)

set alternate to
close database

modi comm (lcPrg)

return
**********************************
function lTbls( taTbls, tcMod, tcType )

local ;
	lnTbls, lnTbl, lcTbl

lnTbls = Alen( taTbls )

if lnTbls > 0

	for each lcTbl in taTbls
		lcTbl = Trim( lcTbl )
		do case
			CASE tcMod = "STRUCTURE"
			   lTblStr( lcTbl )
			CASE tcMod = "DATA"
			   lTblDta( lcTbl )
		endcase
	endfor

endif

return
**********************************
function lTblStr( tcTbl )

local laFlds(1), lnFlds, lnFld, lcFldNam
use (tcTbl)
? "create table " + tcTbl + " ( ;"
lnFlds = aFields( laFlds )
for lnFld = 1 to lnFlds
   lFld( lnFld, laFlds( lnFld, 1), laFlds( lnFld, 2 ), laFlds( lnFld, 3 ), laFlds( lnFld, 4 ) )
endfor

?? " ;"
? ")"
for lnTag = 1 to tagcount()
   do case
   	case primary( lnTag )
   		lKey( "primary key", tcTbl, key(lnTag), tag( lnTag ) )
	case candidate( lnTag )
   		lKey( "unique", tcTbl, key(lnTag), tag( lnTag ) )
	otherwise
   endcase
endfor
?
return

**********************************
function lFld( tcSeq, tcNam, tcTyp, tnWth, tnDec )

?? IIF( tcSeq <> 1, ", ;", "" )

? " " + tcNam + " " + tcTyp

do case
case tcTyp = 'C'
   ?? '('+transform( tnWth )+')'
case tcTyp = 'N'
   ?? '( '+transform( tnWth )+', '+transform( tnDec ) + ' )'
endcase

return
**********************************
function lKey( tcTyp, tcTbl, tcIdxExp, tcTagNam )
? "alter table " + tcTbl + " add " + tcTyp + " " + tcIdxExp + " tag " + tcTagNam
return
**********************************
function lRels()

local laRels(1), lnRels, lnRel

lnRels = ADBOBJECTS( laRels, "Relation" )

for lnRel = 1 to lnRels
   lRel( laRels( lnRel, 1 ), laRels( lnRel, 2 ), laRels( lnRel, 3 ), laRels( lnRel, 4 ) )
endfor

return
*********************************
function lRel( tcCld, tcPnt, tcFk, tcPk )

? "alter table " + tcCld + " add foreign key tag " + tcFk + " ;"
? " references " + tcPnt + " tag " + tcPk
?

return
**********************************
function lVues()

local ;
	laVues(1), lnVues, lnVue, lcVue
	
lnVues = ADBOBJECTS( laVues, "View" )
if lnVues > 0
	for each lcVue in laVues
	   lVue( lcVue )
	endfor
endif

return
**********************************
function lVue( tcVue )

local ;
	lcSql, ;
	lcPrmLst

lcSql = dbGetProp( tcVue, "view", "sql" )

? "create sql view " + tcVue + " as ;"
lOutSql( lcSql )

lcPrmLst = dbGetProp( tcVue, 'View', 'ParameterList' ) 
if !empty( lcPrmLst )
	? "dbSetProp( '" + tcVue + "', 'View', 'ParameterList', [" + lcPrmLst + "] )"
endif

?

return
**********************************
function lOutSql( tcSql )

do while "and" $ substr( tcSql, 3 )

	lnPos = at( "and", substr( tcSql, 3 ) ) + 2
	? substr( tcSql, 1, lnPos - 2 ) + " ;"
	tcSql = substr( tcSql, lnPos -1 )
	
enddo
? tcSql

RETURN
**********************************
FUNCTION lTblDta( tcTbl )

local laFlds(1), lnFlds, lnFld, lcFldNam

SELECT * from (tcTbl) into cursor qDat
lnFlds = aFields( laFlds )

SCAN

	? "INSERT INTO " + tcTbl + " values ( "

	for lnFld = 1 to lnFlds

		?? IIF( lnFld>1, ", ", "" )

	   do case
	   	CASE INLIST( laFlds( lnFld, 2 ), "C", "M" )
	   		?? '"'+TRIM( EVALUATE( laFlds( lnFld, 1 ) ) ) + '"'
	   	CASE INLIST( laFlds( lnFld, 2 ), "N", "F", "I", "Y" )
	   		?? TRANSFORM( EVALUATE( laFlds( lnFld, 1 ) ) )
	   	CASE INLIST( laFlds( lnFld, 2 ), "D", "T" )
	   		?? '{'+TRANSFORM( EVALUATE( laFlds( lnFld, 1 ) ) ) + "}"
	   	CASE laFlds( lnFld, 2 ) = "L"
	   		?? TRANSFORM( EVALUATE( laFlds( lnFld, 1 ) ) )
	   	CASE INLIST( laFlds( lnFld, 2 ), "G" )
			? "opps! - can't do this type."
			? laFlds( lnFld, 1 ), laFlds( lnFld, 2 ), laFlds( lnFld, 3 ), laFlds( lnFld, 4 )
		otherwise
			? "opps!"
			? laFlds( lnFld, 1 ), laFlds( lnFld, 2 ), laFlds( lnFld, 3 ), laFlds( lnFld, 4 )
			? EVALUATE( laFlds( lnFld, 1 ) )
			canc
	   ENDCASE
	
	endfor
	
	?? " )"
	exit
	
ENDSCAN 

There is a little problem: the alter table commands don't seem to alter the tables. Bug in VFP? It would be cool if it would just build the create table Tnam (pk i primary key, fk i references pt...), but that would be tricky: you would have to make sure the Parent got built first.
Contributors: Carl Karsten
Category Code Samples
( Topic last updated: 1999.11.08 11:35:45 AM )