***********************************************************************
* Program....: LISTSTRU.PRG
* Author.....: Andy Kramek
* Date.......: 24 September 2001
* Notice.....: Copyright (c) 2001 Tightline Computers Ltd, All Rights Reserved.
* Compiler...: Visual FoxPro 07.00.0000.9262 for Windows 
* Purpose....: Replacement for the List Structure Command
***********************************************************************
LPARAMETERS tcTable, tlNoShow
LOCAL lcTable, lnSelect, lnFields, lcFile, lnH, lnNextByte
LOCAL lcCDX, lcMem, lcDBC, lWasOpen, lcStr, lcAlias, llIsDBC, lcDBCName

*** Clean parameters and ensure a table is available
lcTable = IIF(EMPTY(tcTable) OR VARTYPE(tcTable)#'C', ALIAS(), FORCEEXT( UPPER(ALLTRIM(tcTable)), 'dbf'))
IF EMPTY(lcTable)
    lcTable = GETFILE( 'dbf', 'Structure For', 'Open' )
    IF EMPTY( lcTable )
        RETURN
    ENDIF
ENDIF

*** Open/Select Table if not the selected Alias
lnSelect = SELECT()
lcAlias = JUSTSTEM(lcTable)
lWasOpen = .T.
IF ! ALIAS() == lcAlias
	IF ! USED( lcAlias )
		IF FILE( lcTable )
			USE (lcTable) AGAIN IN 0
			lWasOpen = .F.
		ELSE
			MESSAGEBOX('Table Name ' + lcTable + ' Not Found', 16, 'Duff Name!' )
			RETURN
		ENDIF
	ENDIF
	SELECT (lcAlias)
ENDIF

*** Get field count and File Name
lnFields = FCOUNT()
lcFile = DBF()
*** Open an output file
lnH = FCREATE( lcAlias + '.TXT')

IF UPPER(JUSTEXT(lcFile)) = 'TMP'
	*** Details for Cursor (or View)
	CursorLst( lcAlias, lnH )
ELSE
	*** Details for Table 
	lcDBCName = TableLst( lcFile, lnH)
ENDIF

IF ! EMPTY( lcDBCName )
    *** We have a DBC
    IF ! DBUSED( lcDBCName )
        *** But it's not open
        OPEN DATABASE (lcDBCName)
    ELSE
        *** Make it current
        SET DATABASE TO FORCEEXT( lcDBCName, "" )
    ENDIF
ENDIF

*** Index Details
IndexLst( lnH )

*** Field Details
FieldLst( lnH, NOT EMPTY( lcDbcName ) )

*** Close Output File and Table
FCLOSE( lnH )
IF ! lWasOpen
	USE IN (lcAlias)
ENDIF

IF tlNoShow
    *** Suppress display
ELSE
    *** Show the file
    MODI FILE ( lcAlias + '.TXT') NOWAIT
ENDIF    

*** Clean Up and Exit
SELECT ( lnSelect )
RETURN

*****************************************
* Get Info for Cursors
*****************************************
PROCEDURE CursorLst( tcFile, tnH )
LOCAL ARRAY laFields[1]
LOCAL lcFile, lnFCount, lnCnt, llHasMemo, lcMem
lcFile = ALLTRIM( tcFile )
*** Check for Memo Fields
lnFCount = AFIELDS( laFields )
FOR lnCnt = 1 TO lnFCount
	IF laFields[lnCnt,2] = "M"
		llHasMemo = .T.
		EXIT
	ENDIF
NEXT
*** Compose Output
lcDBC = "Cursor cannot be associated with a DBC"
lcMem = IIF( llHasMemo, lcFile + '.FPT', 'No Memo Fields')
lcCDX = CDX(1)
lcCDX = IIF( EMPTY( lcCDX), 'No Structural Index', lcCDX )
*** Write out
lcStr = 'Structure For: ' + lcFile
FPUTS(tnH, lcStr )
FPUTS(tnH, REPLICATE('=', LEN(lcStr)))
FPUTS(tnH, 'DBC  : ' + lcDBC )
FPUTS(tnH, 'CDX  : ' + lcCDX )
FPUTS(tnH, 'Memo : ' + lcMem )
FPUTS(tnH, '')
RETURN

*****************************************
* Get DBC-Related Info for Tables/DBCs
*****************************************
PROCEDURE TableLst( tcFile, tnH )
LOCAL lcFile, lnDBCH, lnNextByte, lcCDX, lcMem, lcDBC, lnFields, lcAlias, llInDBC
lnFields = FCOUNT()
lcFile = ALLTRIM( tcFile )
lcAlias = JUSTSTEM(tcFile)
*** Close the table
USE
*** Re-Open DBF at low level
lnDBCH = FOPEN( lcFile )
*** Associated files
FSEEK(lnDBCH,28)
lnNextByte = ASC( FREAD(lnDBCH, 1))
IF lnNextByte = 7
	*** The specified file is actually a DBC, not a Table
	llInDBC = .F.
	lcCDX = lcAlias + '.DCX'
	lcMem = lcAlias + '.DCT'
	lcDBC = lcAlias + '.DBC is a Database Container'
ELSE
	*** It's a table after all!
	lcCDX = IIF( lnNextByte%2 = 0, 'No Structural CDX', lcAlias + '.CDX')
	lcMem = IIF( lnNextByte%4 < 2, 'No Memo File',  lcAlias + '.FPT')
    *** So now Read DBC Backlink
    FSEEK(lnDBCH,(33+(lnFields*32)))
    lcDBC = UPPER(ALLTRIM(STRTRAN(FGETS( lnDBCH, 263), CHR(0))))
    IF EMPTY( lcDBC )
        llInDBC = .F.
        lcDBC = "Not Part of a DBC"
    ELSE
        llInDBC = .T.
    ENDIF
    *** Check to see if table allows nulls
    IF 'NULLFLAGS' $ lcDBC
        *** Need to read a different location
    	FSEEK(lnDBCH,(65+(lnFields*32)))
        lcDBC = UPPER(ALLTRIM(STRTRAN(FREAD( lnDBCH, 263), CHR(0))))
    ENDIF        
ENDIF
*** Close File and re-open as a table
FCLOSE( lnDBCH )
*** Write the header info for Tables/DBC
lcStr = 'Structure For: ' + lcFile
FPUTS(tnH, lcStr )
FPUTS(tnH, REPLICATE('=', LEN(lcStr)))
FPUTS(tnH, 'DBC  : ' + lcDBC )
FPUTS(tnH, 'CDX  : ' + lcCDX )
FPUTS(tnH, 'Memo : ' + lcMem )
FPUTS(tnH, '')
USE (lcFile)
*** Return DBC name
RETURN IIF( llInDBC, lcDBC, "" )

*****************************************
* List Index Details
*****************************************
PROCEDURE IndexLst( tnFileHandle )
LOCAL lnH, lnCnt, lcStr
lnH = tnFileHandle
*** Get Index Details
FPUTS( lnH, '' )
IF TAGCOUNT() > 0
	FPUTS(lnH, 'Associated Indexes' )
	FPUTS(lnH, '==================' )
	*** We have indexes
	*** NB Maybe we should save these to an array and sort it too!
	*** Primary first, then Candidate, then others?
	FOR lnCnt = 1 TO TAGCOUNT()
		lcStr = ""
		*** Check for PK
		IF PRIMARY( lnCnt )
			lcStr = "*** PRIMARY KEY: "
		ELSE
			*** Check for Candidate
			IF Candidate( lnCnt )
				lcStr = "(Candidate): "
			ENDIF
		ENDIF
		lcStr = CHR(9) + lcStr + TAG(lnCnt) + ": " + KEY(lnCnt)
		FPUTS(lnH, lcStr )
	NEXT
ELSE
	*** No Associated indexes
	FPUTS( lnH, 'No Associated Indexes' )
	FPUTS( lnH, '=====================' )
ENDIF
RETURN

*****************************************
* List Field Details
*****************************************
PROCEDURE FieldLst( tnFileHandle, tlIsDBC )
LOCAL ARRAY laFields[1]
LOCAL lnH, lcStr, lnFields, lnCnt, lnMax, lcFldList, lcT

lnH = tnFileHandle

*** No DBC so just use AFIELDS()
*** Get the structure into an array
lnFields = AFIELDS( laFields )
*** Table Details
FPUTS(lnH, CHR(13) + "Table Information" )
FPUTS(lnH, "=================" )
IF !EMPTY(laFields[1,12])
	*** DBC Table Name
	lcStr = "Long Name: " + laFields[1,12]
	FPUTS(lnH, lcStr )
ENDIF
IF !EMPTY(laFields[1,16])
	*** Table Comment
	lcStr = "Comment: " + laFields[1,16]
	FPUTS(lnH, lcStr )
ELSE
	lcStr = "No Comment Supplied"
	FPUTS(lnH, lcStr )
ENDIF
IF ! EMPTY(laFields[1,10])
	lcStr = CHR(9) + 'Table Rule: ' + laFields[1,10] ;
		+ ' (Error Message: ' ;
		+ IIF( EMPTY(laFields[1,11]), 'VFP Default', laFields[1,11] ) ;
		+ ')'
	FPUTS(lnH, lcStr )
ELSE
	lcStr = "No Table Rule"
	FPUTS(lnH, lcStr )
ENDIF
IF !EMPTY(laFields[1,13])
	*** Insert Trigger
	lcStr = CHR(9) + "On Insert: " + laFields[1,13]
	FPUTS(lnH, lcStr )
ELSE
	lcStr = "No Insert Trigger"
	FPUTS(lnH, lcStr )
ENDIF
IF !EMPTY(laFields[1,14])
	*** Update Trigger
	lcStr = CHR(9) + "On Update: " + laFields[1,14]
	FPUTS(lnH, lcStr )
ELSE
	lcStr = "No Update Trigger"
	FPUTS(lnH, lcStr )
ENDIF
IF !EMPTY(laFields[1,15])
	*** Delete Trigger
	lcStr = CHR(9) + "On Delete: " + laFields[1,15]
	FPUTS(lnH, lcStr )
ELSE
	lcStr = "No Delete Trigger"
	FPUTS(lnH, lcStr )
ENDIF

FPUTS(lnH, '' )
FPUTS(lnH, 'Field Details' )
FPUTS(lnH, '=============' )
lnMax = 0
*** Find longest Field Name
FOR lnCnt = 1 TO lnFields
	lnMax = MAX( lnMax, LEN(ALLTRIM(laFields[lnCnt,1])))
NEXT

*** Output field Data
lcFldList = ""
FOR lnCnt = 1 TO lnFields
	*** Field Definition
	lcStr = CHR(9) + PADR(LOWER(laFields[lnCnt,1]),lnMax) + CHR(9) ;
			+ laFields[lnCnt,2] + " (" ;
			+ PADL( laFields[lnCnt,3], 3 ) + ',' ;
			+ ALLTRIM( STR( laFields[lnCnt,4] )) + ' )' + CHR(9) ;
			+ IIF( laFields[lnCnt,5], 'NULL', 'NOT NULL' )
	FPUTS(lnH, lcStr )
    
  *** Add Field Name to Field List
  lcFldList = lcFldList + IIF( !EMPTY( lcFldList ), ", ", "" ) + LOWER( ALLTRIM( laFields[lnCnt,1]))
    
	*** Default Value
	IF ! EMPTY( laFields[lnCnt,9] )
		lcStr = CHR(9) + CHR(9) + 'Default: ' + laFields[lnCnt,9] ;
				+ ' (Error Message: ' ;
				+ IIF( EMPTY(laFields[lnCnt,7]), 'VFP Default', laFields[lnCnt,8] ) ;
				+ ')'
	ELSE
	    lcStr = ""
	ENDIF
	IF ! EMPTY( lcStr )
		FPUTS(lnH, lcStr )
	ENDIF
	
	*** Field Level Validation
	IF ! EMPTY( laFields[lnCnt,7] )
		lcStr = CHR(9) + CHR(9) + 'Valid: ' + laFields[lnCnt,7] ;
				+ ' (Error Message: ' ;
				+ IIF( EMPTY(laFields[lnCnt,8]), 'VFP Default', laFields[lnCnt,8] ) ;
				+ ')'
	ELSE
	    lcStr = ""
	ENDIF
	IF ! EMPTY( lcStr )
		FPUTS(lnH, lcStr )
	ENDIF

    *** Comment
    IF tlIsDBC
        STORE "" TO lcStr, lcT
        *** We have a DBC - get some properties
        lcT = DBGETPROP( ALLTRIM(ALIAS()) + "." + laFields[ lnCnt,1], "FIELD", "COMMENT" )
        lcStr = IIF( ! EMPTY( lcT ), CHR(9) + CHR(9) + 'Comment: ' + lcT, "" )
        lcT = DBGETPROP( ALLTRIM(ALIAS()) + "." + laFields[ lnCnt,1], "FIELD", "CAPTION" )
        lcStr = lcStr + IIF( EMPTY( lcStr ), "", CHR(13) )
        lcStr = lcStr + IIF( ! EMPTY( lcT ), CHR(9) + CHR(9) + 'Caption: ' + lcT, "" )
    ELSE
        lcStr = ""
    ENDIF
	IF ! EMPTY( lcStr )
		FPUTS(lnH, lcStr )
	ENDIF
NEXT

*** Output Field List
FPUTS(lnH, CHR(13) + "Field List" )
FPUTS(lnH, "==========" )
FPUTS(lnH, lcFldList )

RETURN