From cb01febcd3d3067e2a916b0cd2542e633e503a76 Mon Sep 17 00:00:00 2001 From: Fabrice Foray Date: Wed, 27 May 2026 15:35:22 +0200 Subject: [PATCH 01/11] [XSharp.VFP] Add CLOSE DATABASES, CLOSE TABLE commands --- src/Common/FoxProCmd.xh | 8 ++ .../XSharp.VFP/Database/DatabaseCommands.prg | 114 ++++++++++++++++++ src/Runtime/XSharp.VFP/XSharp.VFP.xsproj | 1 + 3 files changed, 123 insertions(+) create mode 100644 src/Runtime/XSharp.VFP/Database/DatabaseCommands.prg diff --git a/src/Common/FoxProCmd.xh b/src/Common/FoxProCmd.xh index 72def21efa..48cbe1853c 100644 --- a/src/Common/FoxProCmd.xh +++ b/src/Common/FoxProCmd.xh @@ -562,6 +562,14 @@ #command CREATE DATABASE <(db)> => XSharp.RDD.Dbc.Create( <(db)>) #command DELETE DATABASE <(db)> [] [] => XSharp.RDD.Dbc.Delete( <(db)>, <.del.>, <.rec.>) +// CLOSE DATABASES [ALL] and CLOSE TABLES [ALL] +// Implemented in XSharp.VFP\Database\DatabaseCommands.prg +// Precedence: ALL variants defined last = tried first by the preprocessor. +#command CLOSE DATABASES => __VFPCloseDatabases( .F. ) +#command CLOSE DATABASES ALL => __VFPCloseDatabases( .T. ) +#command CLOSE TABLES => __VFPCloseTables( .F. ) +#command CLOSE TABLES ALL => __VFPCloseTables( .T. ) + // connection commands #command CREATE CONNECTION <(conn)> ; [DATASOURCE <(Dsn)>] ; diff --git a/src/Runtime/XSharp.VFP/Database/DatabaseCommands.prg b/src/Runtime/XSharp.VFP/Database/DatabaseCommands.prg new file mode 100644 index 0000000000..370fefedad --- /dev/null +++ b/src/Runtime/XSharp.VFP/Database/DatabaseCommands.prg @@ -0,0 +1,114 @@ +// DatabaseCommands.prg +// +// Copyright (c) XSharp B.V. All Rights Reserved. +// Licensed under the Apache License, Version 2.0. +// See License.txt in the project root for license information. +// +// Runtime helpers for VFP database/session commands: +// CLOSE DATABASES [ALL] — UDC rules in FoxProCmd.xh +// CLOSE TABLES [ALL] — UDC rules in FoxProCmd.xh + +USING System.Collections.Generic +USING XSharp.RDD + +/// +/// Runtime implementation of VFP CLOSE DATABASES [ALL]. +/// +/// When is .F. (no ALL keyword): +/// +/// If a database is currently active: closes it via DbcManager, +/// then closes all work areas in the current data session. +/// If no database is active: closes all work areas in the current data session +/// (free tables, indexes, format files). +/// +/// +/// +/// When is .T. (ALL keyword present): +/// closes every database tracked by DbcManager, deactivates the current +/// database, and closes all work areas. +/// +/// In both cases work area 1 is selected on exit. +/// +/// Strict VFP semantics for CLOSE DATABASES (without ALL) close only the +/// tables belonging to the active database while leaving free tables open. +/// Identifying which work areas belong to a specific DBC would require iterating +/// all areas and querying DBI_DB_OBJECT for each. For practical purposes +/// DbCloseAll() is used, which is correct for the no-active-database +/// case and a safe superset for the active-database case. +/// +/// +/// +/// Pass .T. for CLOSE DATABASES ALL; +/// pass .F. for plain CLOSE DATABASES. +/// +FUNCTION __VFPCloseDatabases( lAll AS LOGIC ) AS VOID + IF lAll + // ── CLOSE DATABASES ALL ──────────────────────────────────────────── + // Snapshot before iterating: DbcManager.Close() mutates Databases + // in-place, so we must work from a stable copy. + VAR dbList := List{ DbcManager.Databases } + FOREACH VAR oDb IN dbList + DbcManager.Close( oDb:Name ) + NEXT + // Clear the active-database pointer; the object was already removed + // from DbcManager.Databases above but ActiveDatabase still references it. + DbcManager.Activate( NULL_OBJECT ) + ELSE + // ── CLOSE DATABASES (no ALL) ─────────────────────────────────────── + VAR oActive := DbcManager.ActiveDatabase + IF oActive != NULL_OBJECT + // Close the current database and deactivate it. + // DbcManager.Close() removes it from the Databases list and + // closes its internal work area in DbcDataSession. + DbcManager.Close( oActive:Name ) + // Clear the ActiveDatabase pointer. + DbcManager.Activate( NULL_OBJECT ) + ENDIF + // When no active database, VFP closes all free tables in the current + // data session — handled below by DbCloseAll(). + ENDIF + + // Close all user work areas in the current data session. + // This covers both DBC-owned tables and free tables. + DbCloseAll() + + // VFP always selects work area 1 after CLOSE DATABASES [ALL]. + DbSelectArea( 1 ) + +/// +/// Runtime implementation of VFP CLOSE TABLES [ALL]. +/// +/// Closes open table work areas without closing any open databases (DBCs). +/// +/// +/// When is .F. (no ALL keyword): +/// +/// If a database is currently selected: closes the tables of that database. +/// If no database is selected: closes all free tables in all work areas. +/// +/// +/// +/// When is .T. (ALL keyword present): +/// closes all tables in all open databases and all free tables, across all data sessions. +/// Open databases (DBCs) themselves remain open in both cases. +/// +/// Work area 1 is selected on exit. +/// +/// Strict VFP semantics for CLOSE TABLES (without ALL) close only the tables +/// belonging to the currently selected database. Identifying those work areas requires +/// iterating all areas and checking DBI_DB_OBJECT for each. For practical purposes +/// DbCloseAll() is used, which is correct for the no-active-database case +/// and a safe superset for the active-database case. +/// +/// +/// +/// Pass .T. for CLOSE TABLES ALL; +/// pass .F. for plain CLOSE TABLES. +/// +FUNCTION __VFPCloseTables( lAll AS LOGIC ) AS VOID + // Close all user work areas in the current data session. + // Open databases (DBCs) are NOT affected — DbcManager is untouched. + DbCloseAll() + + // VFP always selects work area 1 after CLOSE TABLES [ALL]. + DbSelectArea( 1 ) diff --git a/src/Runtime/XSharp.VFP/XSharp.VFP.xsproj b/src/Runtime/XSharp.VFP/XSharp.VFP.xsproj index cf69e82931..8742a52830 100644 --- a/src/Runtime/XSharp.VFP/XSharp.VFP.xsproj +++ b/src/Runtime/XSharp.VFP/XSharp.VFP.xsproj @@ -60,6 +60,7 @@ + From ff0f693924a327b7860e33f1c68b86e47018ec69 Mon Sep 17 00:00:00 2001 From: Fabrice Foray Date: Wed, 27 May 2026 15:45:46 +0200 Subject: [PATCH 02/11] [XSharp.Core / XSharp.VFP] Add commands CLOSE DATABASES, CLOSE TABLES --- src/Common/FoxProCmd.xh | 8 ++ .../XSharp.VFP/Database/DatabaseCommands.prg | 114 ++++++++++++++++++ src/Runtime/XSharp.VFP/XSharp.VFP.xsproj | 1 + 3 files changed, 123 insertions(+) create mode 100644 src/Runtime/XSharp.VFP/Database/DatabaseCommands.prg diff --git a/src/Common/FoxProCmd.xh b/src/Common/FoxProCmd.xh index 72def21efa..48cbe1853c 100644 --- a/src/Common/FoxProCmd.xh +++ b/src/Common/FoxProCmd.xh @@ -562,6 +562,14 @@ #command CREATE DATABASE <(db)> => XSharp.RDD.Dbc.Create( <(db)>) #command DELETE DATABASE <(db)> [] [] => XSharp.RDD.Dbc.Delete( <(db)>, <.del.>, <.rec.>) +// CLOSE DATABASES [ALL] and CLOSE TABLES [ALL] +// Implemented in XSharp.VFP\Database\DatabaseCommands.prg +// Precedence: ALL variants defined last = tried first by the preprocessor. +#command CLOSE DATABASES => __VFPCloseDatabases( .F. ) +#command CLOSE DATABASES ALL => __VFPCloseDatabases( .T. ) +#command CLOSE TABLES => __VFPCloseTables( .F. ) +#command CLOSE TABLES ALL => __VFPCloseTables( .T. ) + // connection commands #command CREATE CONNECTION <(conn)> ; [DATASOURCE <(Dsn)>] ; diff --git a/src/Runtime/XSharp.VFP/Database/DatabaseCommands.prg b/src/Runtime/XSharp.VFP/Database/DatabaseCommands.prg new file mode 100644 index 0000000000..370fefedad --- /dev/null +++ b/src/Runtime/XSharp.VFP/Database/DatabaseCommands.prg @@ -0,0 +1,114 @@ +// DatabaseCommands.prg +// +// Copyright (c) XSharp B.V. All Rights Reserved. +// Licensed under the Apache License, Version 2.0. +// See License.txt in the project root for license information. +// +// Runtime helpers for VFP database/session commands: +// CLOSE DATABASES [ALL] — UDC rules in FoxProCmd.xh +// CLOSE TABLES [ALL] — UDC rules in FoxProCmd.xh + +USING System.Collections.Generic +USING XSharp.RDD + +/// +/// Runtime implementation of VFP CLOSE DATABASES [ALL]. +/// +/// When is .F. (no ALL keyword): +/// +/// If a database is currently active: closes it via DbcManager, +/// then closes all work areas in the current data session. +/// If no database is active: closes all work areas in the current data session +/// (free tables, indexes, format files). +/// +/// +/// +/// When is .T. (ALL keyword present): +/// closes every database tracked by DbcManager, deactivates the current +/// database, and closes all work areas. +/// +/// In both cases work area 1 is selected on exit. +/// +/// Strict VFP semantics for CLOSE DATABASES (without ALL) close only the +/// tables belonging to the active database while leaving free tables open. +/// Identifying which work areas belong to a specific DBC would require iterating +/// all areas and querying DBI_DB_OBJECT for each. For practical purposes +/// DbCloseAll() is used, which is correct for the no-active-database +/// case and a safe superset for the active-database case. +/// +/// +/// +/// Pass .T. for CLOSE DATABASES ALL; +/// pass .F. for plain CLOSE DATABASES. +/// +FUNCTION __VFPCloseDatabases( lAll AS LOGIC ) AS VOID + IF lAll + // ── CLOSE DATABASES ALL ──────────────────────────────────────────── + // Snapshot before iterating: DbcManager.Close() mutates Databases + // in-place, so we must work from a stable copy. + VAR dbList := List{ DbcManager.Databases } + FOREACH VAR oDb IN dbList + DbcManager.Close( oDb:Name ) + NEXT + // Clear the active-database pointer; the object was already removed + // from DbcManager.Databases above but ActiveDatabase still references it. + DbcManager.Activate( NULL_OBJECT ) + ELSE + // ── CLOSE DATABASES (no ALL) ─────────────────────────────────────── + VAR oActive := DbcManager.ActiveDatabase + IF oActive != NULL_OBJECT + // Close the current database and deactivate it. + // DbcManager.Close() removes it from the Databases list and + // closes its internal work area in DbcDataSession. + DbcManager.Close( oActive:Name ) + // Clear the ActiveDatabase pointer. + DbcManager.Activate( NULL_OBJECT ) + ENDIF + // When no active database, VFP closes all free tables in the current + // data session — handled below by DbCloseAll(). + ENDIF + + // Close all user work areas in the current data session. + // This covers both DBC-owned tables and free tables. + DbCloseAll() + + // VFP always selects work area 1 after CLOSE DATABASES [ALL]. + DbSelectArea( 1 ) + +/// +/// Runtime implementation of VFP CLOSE TABLES [ALL]. +/// +/// Closes open table work areas without closing any open databases (DBCs). +/// +/// +/// When is .F. (no ALL keyword): +/// +/// If a database is currently selected: closes the tables of that database. +/// If no database is selected: closes all free tables in all work areas. +/// +/// +/// +/// When is .T. (ALL keyword present): +/// closes all tables in all open databases and all free tables, across all data sessions. +/// Open databases (DBCs) themselves remain open in both cases. +/// +/// Work area 1 is selected on exit. +/// +/// Strict VFP semantics for CLOSE TABLES (without ALL) close only the tables +/// belonging to the currently selected database. Identifying those work areas requires +/// iterating all areas and checking DBI_DB_OBJECT for each. For practical purposes +/// DbCloseAll() is used, which is correct for the no-active-database case +/// and a safe superset for the active-database case. +/// +/// +/// +/// Pass .T. for CLOSE TABLES ALL; +/// pass .F. for plain CLOSE TABLES. +/// +FUNCTION __VFPCloseTables( lAll AS LOGIC ) AS VOID + // Close all user work areas in the current data session. + // Open databases (DBCs) are NOT affected — DbcManager is untouched. + DbCloseAll() + + // VFP always selects work area 1 after CLOSE TABLES [ALL]. + DbSelectArea( 1 ) diff --git a/src/Runtime/XSharp.VFP/XSharp.VFP.xsproj b/src/Runtime/XSharp.VFP/XSharp.VFP.xsproj index cf69e82931..8742a52830 100644 --- a/src/Runtime/XSharp.VFP/XSharp.VFP.xsproj +++ b/src/Runtime/XSharp.VFP/XSharp.VFP.xsproj @@ -60,6 +60,7 @@ + From 57c14934628a95ef7cd4282008dd541e1ca75c05 Mon Sep 17 00:00:00 2001 From: Fabrice Foray Date: Wed, 27 May 2026 15:49:51 +0200 Subject: [PATCH 03/11] [XSharp.Core] Fix visibility to give access to the ActiveDataBase for CLOSE DATABASES --- src/Runtime/XSharp.Core/RDD/DbcSupport.prg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Runtime/XSharp.Core/RDD/DbcSupport.prg b/src/Runtime/XSharp.Core/RDD/DbcSupport.prg index f984ecd6c6..dcc566e32d 100644 --- a/src/Runtime/XSharp.Core/RDD/DbcSupport.prg +++ b/src/Runtime/XSharp.Core/RDD/DbcSupport.prg @@ -15,7 +15,7 @@ BEGIN NAMESPACE XSharp.RDD STATIC PRIVATE _databases AS List STATIC PRIVATE PROPERTY DbcDataSession AS DataSession AUTO - STATIC INTERNAL PROPERTY ActiveDatabase AS DbcDatabase AUTO + STATIC PUBLIC PROPERTY ActiveDatabase AS DbcDatabase AUTO GET PRIVATE SET STATIC PROPERTY Databases AS IList GET _databases From 0d1f1a0e22dec1dc9cc6d13db2b309f2123e15dd Mon Sep 17 00:00:00 2001 From: Robert van der Hulst Date: Wed, 27 May 2026 16:08:45 +0200 Subject: [PATCH 04/11] [UDC] Merged CLOSE DATABASES and CLOSE TABLES variants into single UDC --- src/Common/FoxProCmd.xh | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Common/FoxProCmd.xh b/src/Common/FoxProCmd.xh index 48cbe1853c..1ce419f340 100644 --- a/src/Common/FoxProCmd.xh +++ b/src/Common/FoxProCmd.xh @@ -564,11 +564,9 @@ // CLOSE DATABASES [ALL] and CLOSE TABLES [ALL] // Implemented in XSharp.VFP\Database\DatabaseCommands.prg -// Precedence: ALL variants defined last = tried first by the preprocessor. -#command CLOSE DATABASES => __VFPCloseDatabases( .F. ) -#command CLOSE DATABASES ALL => __VFPCloseDatabases( .T. ) -#command CLOSE TABLES => __VFPCloseTables( .F. ) -#command CLOSE TABLES ALL => __VFPCloseTables( .T. ) + +#command CLOSE DATABASES [] => __VFPCloseDatabases( <.all.> ) +#command CLOSE TABLES [ => __VFPCloseTables( <.all.> ) // connection commands #command CREATE CONNECTION <(conn)> ; From fc509a1d34bb10b730c97eaca04b56bb1e6e685a Mon Sep 17 00:00:00 2001 From: Fabrice Foray Date: Wed, 27 May 2026 16:26:36 +0200 Subject: [PATCH 05/11] [XSharp.Core / XSharp.VFP] Add support for ADD TABLE, REMOVE TABLE, RENAME TABLE in DBCs --- src/Common/FoxProCmd.xh | 20 ++ src/Runtime/XSharp.Core/RDD/DbcSupport.prg | 313 ++++++++++++++++++ src/Runtime/XSharp.Core/RDD/IMemo.prg | 21 ++ src/Runtime/XSharp.Rdd/DbfVfp/DbfVfp.prg | 45 ++- .../XSharp.VFP/Database/DatabaseCommands.prg | 46 +++ 5 files changed, 442 insertions(+), 3 deletions(-) diff --git a/src/Common/FoxProCmd.xh b/src/Common/FoxProCmd.xh index 48cbe1853c..0195262bb5 100644 --- a/src/Common/FoxProCmd.xh +++ b/src/Common/FoxProCmd.xh @@ -570,6 +570,26 @@ #command CLOSE TABLES => __VFPCloseTables( .F. ) #command CLOSE TABLES ALL => __VFPCloseTables( .T. ) +// ADD TABLE TableName [NAME LongTableName] +// Links an existing free .DBF to the currently active database. +// Implemented in XSharp.VFP\Database\DatabaseCommands.prg +// The NAME variant is defined last (tried first) to correctly consume the NAME clause. +#command ADD TABLE <(file)> => __VFPAddTable( <(file)>, "") +#command ADD TABLE <(file)> NAME <(name)> => __VFPAddTable( <(file)>, <(name)>) + +// REMOVE TABLE TableName [DELETE] [RECYCLE] +// Unlinks a table from the active database; optionally deletes the .DBF file. +// Implemented in XSharp.VFP\Database\DatabaseCommands.prg +// Precedence: most-specific forms defined last = tried first. +#command REMOVE TABLE <(name)> => __VFPRemoveTable( <(name)>, .F., .F.) +#command REMOVE TABLE <(name)> DELETE => __VFPRemoveTable( <(name)>, .T., .F.) +#command REMOVE TABLE <(name)> RECYCLE => __VFPRemoveTable( <(name)>, .F., .T.) + +// RENAME TABLE OldName TO NewName +// Changes the logical name in the DBC; does not rename the physical .DBF. +// Implemented in XSharp.VFP\Database\DatabaseCommands.prg +#command RENAME TABLE <(old)> TO <(new)> => __VFPRenameTable( <(old)>, <(new)>) + // connection commands #command CREATE CONNECTION <(conn)> ; [DATASOURCE <(Dsn)>] ; diff --git a/src/Runtime/XSharp.Core/RDD/DbcSupport.prg b/src/Runtime/XSharp.Core/RDD/DbcSupport.prg index dcc566e32d..555fc3b144 100644 --- a/src/Runtime/XSharp.Core/RDD/DbcSupport.prg +++ b/src/Runtime/XSharp.Core/RDD/DbcSupport.prg @@ -119,6 +119,308 @@ BEGIN NAMESPACE XSharp.RDD ENDIF RETURN lOk + /// + /// Implements VFP ADD TABLE TableName [NAME LongTableName]. + /// Links an existing free .DBF file to the currently active database. + /// + /// + /// Physical path to the .DBF file (extension optional). The file must exist and + /// must be a free table (empty backlink). + /// + /// + /// Optional logical name stored in the DBC OBJECTNAME field. + /// When empty or NULL, the filename without extension is used. + /// + /// .T. on success; .F. on failure (error stored in + /// RuntimeState.LastRddError). + STATIC METHOD AddTable(cFileName AS STRING, cLongName AS STRING) AS LOGIC + // ── Validate pre-conditions ──────────────────────────────────────── + LOCAL oActiveDbc := DbcManager.ActiveDatabase AS DbcDatabase + IF oActiveDbc == NULL_OBJECT + Fail(Error{"ADD TABLE: no active database (use SET DATABASE TO first)"}) + RETURN FALSE + ENDIF + // Resolve file extension + IF String.IsNullOrEmpty(System.IO.Path.GetExtension(cFileName)) + cFileName := System.IO.Path.ChangeExtension(cFileName, ".DBF") + ENDIF + cFileName := System.IO.Path.GetFullPath(cFileName) + IF ! System.IO.File.Exists(cFileName) + Fail(Error{"ADD TABLE: file not found: " + cFileName}) + RETURN FALSE + ENDIF + // Determine the logical (long) name for the DBC OBJECTNAME field + IF String.IsNullOrEmpty(cLongName) + cLongName := System.IO.Path.GetFileNameWithoutExtension(cFileName) + ENDIF + + // ── Open the DBF in a temporary work area in the user data session ── + // IVfpLinked (implemented by DBFVFP) gives us typed access to + // DbcName, DbcPosition, and WriteBacklink without a compile-time + // reference to XSharp.Rdd. + LOCAL lOk := FALSE AS LOGIC + LOCAL oVfp := NULL AS IVfpLinked + LOCAL nArea := 0 AS DWORD + + IF ! CoreDb.UseArea(TRUE, "DBFVFP", cFileName, "_ADDTBL_", FALSE, FALSE) + Fail(Error{"ADD TABLE: cannot open " + cFileName}) + RETURN FALSE + ENDIF + nArea := RuntimeState.Workareas:CurrentWorkarea:Area + + // Retrieve the RDD object via IVfpLinked + LOCAL oRddVal := NULL AS OBJECT + IF CoreDb.Info(DBI_RDD_OBJECT, REF oRddVal) .AND. oRddVal IS IVfpLinked VAR vfp + oVfp := vfp + ENDIF + IF oVfp == NULL + CoreDb.CloseArea() + Fail(Error{"ADD TABLE: driver does not implement IVfpLinked for " + cFileName}) + RETURN FALSE + ENDIF + + // ── Verify the table is a free table (empty backlink) ────────────── + IF ! String.IsNullOrEmpty(oVfp:DbcName) + CoreDb.CloseArea() + Fail(Error{"ADD TABLE: " + cFileName + " is already linked to a database"}) + RETURN FALSE + ENDIF + + // ── Collect field names via IRdd (physical DBF names). + // These become the DBC OBJECTNAME values for Field records. + LOCAL aFieldNames := List{} AS List + IF oVfp IS IRdd VAR oRdd + LOCAL nFldCount := oRdd:FieldCount AS LONG + FOR LOCAL nFld := 1 TO nFldCount + aFieldNames:Add(oRdd:FieldName(nFld)) + NEXT + ENDIF + + // ── Register Table + Field records in the DBC ────────────────────── + // DoForDatabase switches to DbcDataSession; on return we are back in + // the user session with the DBF area still selected. + lOk := DbcManager.DoForDatabase({ => + LOCAL nOld AS DWORD + CoreDb.Select(oActiveDbc:Area, OUT nOld) + + // Determine the next free OBJECTID from the last record. + // A valid DBC always has at least the built-in Database records. + CoreDb.GoBottom() + LOCAL nNextId AS INT + IF CoreDb.Eof() + nNextId := 1 + ELSE + LOCAL oIdVal := NULL AS OBJECT + CoreDb.FieldGet(DbcObject.POS_OBJECTID, REF oIdVal) + nNextId := ((INT) oIdVal) + 1 + ENDIF + LOCAL nTableId := nNextId AS INT + + // ── Table record ─────────────────────────────────────────────── + _writeRecord({ nTableId, 1, DbcObject.NAME_TABLE, cLongName }) + + // ── Field records — one per column in DBF position order ──────── + FOREACH VAR cFldName IN aFieldNames + nNextId += 1 + _writeRecord({ nNextId, nTableId, DbcObject.NAME_FIELD, cFldName }) + NEXT + + CoreDb.Commit() + CoreDb.Select(nOld, OUT NULL) + RETURN TRUE + }) + + IF lOk + // ── Write the backlink into the DBF header ───────────────────── + // Back in the user session with area = the DBF. + CoreDb.Select(nArea, OUT NULL) + LOCAL cRelative AS STRING + cRelative := _MakeRelativePath(cFileName, oActiveDbc:FileName) + oVfp:WriteBacklink(cRelative) + // Flush via IRdd — WriteBacklink wrote directly to the stream; + // this ensures any pending record buffer is also committed. + IF oVfp IS IRdd VAR oRddFlush + oRddFlush:Flush() + ENDIF + // Reload the DBC in-memory cache so the new table is immediately visible + oActiveDbc:Reload() + ENDIF + + // Always close the temporary work area + CoreDb.Select(nArea, OUT NULL) + CoreDb.CloseArea() + RETURN lOk + + /// + /// Compute a relative path from to . + /// Returns just the filename when both files share the same directory; + /// otherwise returns the absolute path of . + /// + PRIVATE STATIC METHOD _MakeRelativePath(cFromFile AS STRING, cToFile AS STRING) AS STRING + LOCAL fromDir := System.IO.Path.GetDirectoryName( ; + System.IO.Path.GetFullPath(cFromFile)) AS STRING + LOCAL toFull := System.IO.Path.GetFullPath(cToFile) AS STRING + LOCAL toDir := System.IO.Path.GetDirectoryName(toFull) AS STRING + IF String.Compare(fromDir, toDir, StringComparison.OrdinalIgnoreCase) == 0 + RETURN System.IO.Path.GetFileName(toFull) + ENDIF + RETURN toFull + + /// + /// Implements VFP REMOVE TABLE TableName [DELETE] [RECYCLE]. + /// Unlinks an existing table from the active database. + /// + /// + /// Logical name (OBJECTNAME in the DBC) of the table to remove. + /// + /// + /// When .T., delete the .DBF file (and companion .FPT/.CDX) from disk. + /// + /// + /// When .T., move the file to the Recycle Bin instead of deleting. + /// Currently treated the same as (shell API not yet implemented). + /// + /// .T. on success; .F. otherwise. + STATIC METHOD RemoveTable(cName AS STRING, lDelete AS LOGIC, lRecycle AS LOGIC) AS LOGIC + LOCAL oActiveDbc := DbcManager.ActiveDatabase AS DbcDatabase + IF oActiveDbc == NULL_OBJECT + Fail(Error{"REMOVE TABLE: no active database (use SET DATABASE TO first)"}) + RETURN FALSE + ENDIF + + // Locate the table in the in-memory cache to get its ObjectID + LOCAL oTable := oActiveDbc:FindTable(cName) AS DbcTable + IF oTable == NULL_OBJECT + Fail(Error{"REMOVE TABLE: table '" + cName + "' not found in active database"}) + RETURN FALSE + ENDIF + LOCAL nTableId := (INT) oTable:ObjectID AS INT + + // Determine physical .DBF path (needed for backlink zeroing and optional deletion) + LOCAL cDbfPath := oTable:Path AS STRING + IF String.IsNullOrEmpty(cDbfPath) + // Path not stored in DBC — fall back to: same directory as DBC, same name as table + cDbfPath := System.IO.Path.Combine( ; + System.IO.Path.GetDirectoryName(oActiveDbc:FileName), ; + cName + ".DBF") + ENDIF + cDbfPath := System.IO.Path.GetFullPath(cDbfPath) + + // ── Remove Table + all child records from the DBC ────────────────── + LOCAL lOk := DbcManager.DoForDatabase({ => + LOCAL nOld AS DWORD + CoreDb.Select(oActiveDbc:Area, OUT nOld) + CoreDb.GoTop() + DO WHILE ! CoreDb.Eof() + LOCAL oId := NULL AS OBJECT + LOCAL oParent := NULL AS OBJECT + CoreDb.FieldGet(DbcObject.POS_OBJECTID, REF oId) + CoreDb.FieldGet(DbcObject.POS_PARENTID, REF oParent) + IF (INT) oId == nTableId .OR. (INT) oParent == nTableId + CoreDb.Delete() + ENDIF + CoreDb.Skip(1) + ENDDO + CoreDb.Commit() + CoreDb.Select(nOld, OUT NULL) + RETURN TRUE + }) AS LOGIC + + IF lOk + // ── Zero the backlink in the DBF header ──────────────────────── + IF System.IO.File.Exists(cDbfPath) + IF CoreDb.UseArea(TRUE, "DBFVFP", cDbfPath, "_REMTBL_", FALSE, FALSE) + LOCAL nArea := RuntimeState.Workareas:CurrentWorkarea:Area AS DWORD + LOCAL oRddVal := NULL AS OBJECT + IF CoreDb.Info(DBI_RDD_OBJECT, REF oRddVal) .AND. oRddVal IS IVfpLinked VAR vfp + vfp:WriteBacklink("") // zero = free table again + IF vfp IS IRdd VAR rdd + rdd:Flush() + ENDIF + ENDIF + CoreDb.Select(nArea, OUT NULL) + CoreDb.CloseArea() + ENDIF + + // ── Optionally delete / recycle the .DBF and companions ──── + // TODO: RECYCLE should use Shell32 SHFileOperation to move to the + // Recycle Bin. Until then it is treated the same as DELETE. + IF lDelete .OR. lRecycle + LOCAL cBase := System.IO.Path.Combine( ; + System.IO.Path.GetDirectoryName(cDbfPath), ; + System.IO.Path.GetFileNameWithoutExtension(cDbfPath)) AS STRING + TRY + System.IO.File.Delete(cDbfPath) + LOCAL cMemo := cBase + ".FPT" AS STRING + IF System.IO.File.Exists(cMemo) + System.IO.File.Delete(cMemo) + ENDIF + LOCAL cIdx := cBase + ".CDX" AS STRING + IF System.IO.File.Exists(cIdx) + System.IO.File.Delete(cIdx) + ENDIF + CATCH e AS Exception + Fail(e) + lOk := FALSE + END TRY + ENDIF + ENDIF + + // Reload the DBC in-memory cache + oActiveDbc:Reload() + ENDIF + RETURN lOk + + /// + /// Implements VFP RENAME TABLE OldName TO NewName. + /// Changes the logical name (OBJECTNAME) of a table entry inside the DBC. + /// The physical .DBF file is not renamed. + /// + /// Current logical name of the table in the DBC. + /// New logical name to assign. + /// .T. on success; .F. otherwise. + STATIC METHOD RenameTable(cOldName AS STRING, cNewName AS STRING) AS LOGIC + LOCAL oActiveDbc := DbcManager.ActiveDatabase AS DbcDatabase + IF oActiveDbc == NULL_OBJECT + Fail(Error{"RENAME TABLE: no active database (use SET DATABASE TO first)"}) + RETURN FALSE + ENDIF + + LOCAL oTable := oActiveDbc:FindTable(cOldName) AS DbcTable + IF oTable == NULL_OBJECT + Fail(Error{"RENAME TABLE: table '" + cOldName + "' not found in active database"}) + RETURN FALSE + ENDIF + LOCAL nTableId := (INT) oTable:ObjectID AS INT + + // Find the Table record in the DBC by ObjectID and update OBJECTNAME + LOCAL lOk := DbcManager.DoForDatabase({ => + LOCAL nOld AS DWORD + CoreDb.Select(oActiveDbc:Area, OUT nOld) + CoreDb.GoTop() + LOCAL lFound := FALSE AS LOGIC + DO WHILE ! CoreDb.Eof() + LOCAL oId := NULL AS OBJECT + CoreDb.FieldGet(DbcObject.POS_OBJECTID, REF oId) + IF (INT) oId == nTableId + CoreDb.FieldPut(DbcObject.POS_OBJECTNAME, (OBJECT) cNewName) + lFound := TRUE + EXIT + ENDIF + CoreDb.Skip(1) + ENDDO + IF lFound + CoreDb.Commit() + ENDIF + CoreDb.Select(nOld, OUT NULL) + RETURN lFound + }) AS LOGIC + + IF lOk + oActiveDbc:Reload() + ENDIF + RETURN lOk + /// STATIC METHOD FindDatabase(cFileName as STRING) AS DbcDatabase FOREACH var oDb in Databases @@ -355,6 +657,17 @@ BEGIN NAMESPACE XSharp.RDD ENDIF NEXT + /// + /// Clears the in-memory table/view/connection caches and re-reads all + /// children from the DBC work area. Call this after structural changes + /// such as ADD TABLE or REMOVE TABLE. + /// + INTERNAL METHOD Reload() AS VOID + _tables:Clear() + _views:Clear() + _connections:Clear() + _other:Clear() + SELF:GetData() /// PUBLIC METHOD GetProp(cName as STRING, cType as STRING, cProp as STRING) AS OBJECT diff --git a/src/Runtime/XSharp.Core/RDD/IMemo.prg b/src/Runtime/XSharp.Core/RDD/IMemo.prg index e28c598f1d..cf323488b4 100644 --- a/src/Runtime/XSharp.Core/RDD/IMemo.prg +++ b/src/Runtime/XSharp.Core/RDD/IMemo.prg @@ -43,6 +43,27 @@ INTERFACE XSharp.RDD.IRawData PROPERTY ReturnRawData AS LOGIC GET SET END INTERFACE +/// +/// Implemented by RDD drivers that support VFP DBC backlinks. +/// Used by DbcManager.AddTable to inspect and update the 262-byte +/// backlink slot without requiring a compile-time reference to XSharp.Rdd. +/// +INTERFACE XSharp.RDD.IVfpLinked + /// Gets or sets the fully-qualified path to the DBC this table is linked to, + /// or an empty string when the table is free. + PROPERTY DbcName AS STRING GET SET + + /// Byte offset in the DBF file where the 262-byte backlink begins. + PROPERTY DbcPosition AS INT GET + + /// + /// Writes into the 262-byte backlink area of the DBF header. + /// Pass an empty string to zero the slot (convert to free table). + /// + METHOD WriteBacklink(cPath AS STRING) AS VOID + +END INTERFACE + /// INTERFACE XSharp.RDD.IBlobData /// diff --git a/src/Runtime/XSharp.Rdd/DbfVfp/DbfVfp.prg b/src/Runtime/XSharp.Rdd/DbfVfp/DbfVfp.prg index 6cabb75dbd..20f82d89b7 100644 --- a/src/Runtime/XSharp.Rdd/DbfVfp/DbfVfp.prg +++ b/src/Runtime/XSharp.Rdd/DbfVfp/DbfVfp.prg @@ -15,7 +15,7 @@ USING STATIC XSharp.Conversions BEGIN NAMESPACE XSharp.RDD /// [DebuggerDisplay("DBFVFP ({Alias,nq})")]; -CLASS DBFVFP INHERIT DBFCDX +CLASS DBFVFP INHERIT DBFCDX IMPLEMENTS IVfpLinked PRIVATE CONST VFP_BACKLINKSIZE := 262 AS LONG PRIVATE oDbcTable as DbcTable PROTECT _NullColumn AS DbfNullColumn // Column definition for _NullFlags, used in DBFVFP driver @@ -26,8 +26,8 @@ CLASS DBFVFP INHERIT DBFCDX RETURN OVERRIDE PROPERTY NullColumn as DbfNullColumn => SELF:_NullColumn OVERRIDE PROPERTY Driver AS STRING GET nameof(DBFVFP) - INTERNAL PROPERTY DbcName AS STRING AUTO - INTERNAL PROPERTY DbcPosition AS INT GET DbfHeader.SIZE + SELF:_Fields:Length * DbfField.SIZE +1 + PUBLIC PROPERTY DbcName AS STRING AUTO + PUBLIC PROPERTY DbcPosition AS INT GET DbfHeader.SIZE + SELF:_Fields:Length * DbfField.SIZE +1 INTERNAL PROPERTY DeleteOnClose AS LOGIC AUTO OVERRIDE METHOD Close() AS LOGIC @@ -230,6 +230,45 @@ CLASS DBFVFP INHERIT DBFCDX ENDIF RETURN + /// + /// Writes the 262-byte DBC backlink slot in the DBF header with . + /// Pass an empty string to zero-out the backlink (free-table mode). + /// Implements . + /// + PUBLIC METHOD WriteBacklink(cPath AS STRING) AS VOID + LOCAL nPos := SELF:DbcPosition AS LONG + LOCAL buffer := BYTE[]{VFP_BACKLINKSIZE} AS BYTE[] + IF ! String.IsNullOrEmpty(cPath) + LOCAL bName := System.Text.Encoding.Default:GetBytes(cPath) AS BYTE[] + System.Array.Copy(bName, buffer, Math.Min(bName:Length, VFP_BACKLINKSIZE - 1)) + ENDIF + _oStream:SafeWriteAt(nPos, buffer, buffer:Length) + // Update the in-memory DBC path so subsequent reads are consistent + IF String.IsNullOrEmpty(cPath) + SELF:DbcName := "" + ELSE + SELF:DbcName := System.IO.Path.GetFullPath( ; + System.IO.Path.Combine(System.IO.Path.GetDirectoryName(SELF:_FileName), cPath)) + ENDIF + RETURN + + /// + /// Returns a relative path from to + /// when both files share the same directory; otherwise returns the absolute path of + /// . + /// + PUBLIC STATIC METHOD MakeRelativePath(cFromFile AS STRING, cToFile AS STRING) AS STRING + LOCAL fromDir := System.IO.Path.GetDirectoryName( ; + System.IO.Path.GetFullPath(cFromFile)) AS STRING + LOCAL toFull := System.IO.Path.GetFullPath(cToFile) AS STRING + LOCAL toDir := System.IO.Path.GetDirectoryName(toFull) AS STRING + IF String.Compare(fromDir, toDir, StringComparison.OrdinalIgnoreCase) == 0 + // Same directory — store just the filename (VFP default behaviour) + RETURN System.IO.Path.GetFileName(toFull) + ENDIF + // Different directories — store full absolute path + RETURN toFull + PROTECTED METHOD _ReadDbcFieldNames() AS VOID local cDbcFile as STRING cDbcFile := SELF:DbcName diff --git a/src/Runtime/XSharp.VFP/Database/DatabaseCommands.prg b/src/Runtime/XSharp.VFP/Database/DatabaseCommands.prg index 370fefedad..98f4fb586a 100644 --- a/src/Runtime/XSharp.VFP/Database/DatabaseCommands.prg +++ b/src/Runtime/XSharp.VFP/Database/DatabaseCommands.prg @@ -112,3 +112,49 @@ FUNCTION __VFPCloseTables( lAll AS LOGIC ) AS VOID // VFP always selects work area 1 after CLOSE TABLES [ALL]. DbSelectArea( 1 ) + +/// +/// Runtime implementation of VFP ADD TABLE TableName [NAME LongTableName]. +/// +/// +/// Links an existing free .DBF file to the currently active database (DBC). +/// The DBC must have been opened and set active via OPEN DATABASE / +/// SET DATABASE TO before calling this function. +/// +/// +/// Physical path to the .DBF file. The .DBF extension is added when omitted. +/// The file must exist and must be a free table (empty backlink slot). +/// +/// +/// Logical name stored in the DBC OBJECTNAME field (up to 128 chars). +/// When empty, the filename without extension is used. +/// +/// .T. on success; .F. otherwise. +FUNCTION __VFPAddTable( cFileName AS STRING, cLongName AS STRING ) AS LOGIC + RETURN DbcManager.AddTable( cFileName, cLongName ) + +/// +/// Runtime implementation of VFP REMOVE TABLE TableName [DELETE] [RECYCLE]. +/// +/// Logical name of the table in the active DBC. +/// +/// .T. to delete the .DBF file (and companions) from disk after unlinking. +/// +/// +/// .T. to move the file to the Recycle Bin instead of deleting. +/// (Currently behaves the same as .) +/// +/// .T. on success; .F. otherwise. +FUNCTION __VFPRemoveTable( cName AS STRING, lDelete AS LOGIC, lRecycle AS LOGIC ) AS LOGIC + RETURN DbcManager.RemoveTable( cName, lDelete, lRecycle ) + +/// +/// Runtime implementation of VFP RENAME TABLE OldName TO NewName. +/// Changes the logical name of the table inside the DBC. +/// The physical .DBF file is not renamed. +/// +/// Current logical name of the table. +/// New logical name to assign. +/// .T. on success; .F. otherwise. +FUNCTION __VFPRenameTable( cOldName AS STRING, cNewName AS STRING ) AS LOGIC + RETURN DbcManager.RenameTable( cOldName, cNewName ) From 5d7748c783bc8970b5751811f4fdbcc496e32f80 Mon Sep 17 00:00:00 2001 From: Fabrice Foray Date: Wed, 27 May 2026 17:14:17 +0200 Subject: [PATCH 06/11] [XSharp.Core/Data/VFP] CREATE TABLE: long field name support via DBC --- src/Runtime/XSharp.Core/RDD/DbcSupport.prg | 115 +++++++++++++------ src/Runtime/XSharp.Data/Parser/SQLParser.prg | 9 +- src/Runtime/XSharp.VFP/SQL/EmbeddedSql.prg | 21 +++- 3 files changed, 108 insertions(+), 37 deletions(-) diff --git a/src/Runtime/XSharp.Core/RDD/DbcSupport.prg b/src/Runtime/XSharp.Core/RDD/DbcSupport.prg index 555fc3b144..fac04b76de 100644 --- a/src/Runtime/XSharp.Core/RDD/DbcSupport.prg +++ b/src/Runtime/XSharp.Core/RDD/DbcSupport.prg @@ -122,6 +122,8 @@ BEGIN NAMESPACE XSharp.RDD /// /// Implements VFP ADD TABLE TableName [NAME LongTableName]. /// Links an existing free .DBF file to the currently active database. + /// Reads physical field names from the DBF, then delegates to the + /// overload that accepts a pre-built field-name list. /// /// /// Physical path to the .DBF file (extension optional). The file must exist and @@ -134,6 +136,55 @@ BEGIN NAMESPACE XSharp.RDD /// .T. on success; .F. on failure (error stored in /// RuntimeState.LastRddError). STATIC METHOD AddTable(cFileName AS STRING, cLongName AS STRING) AS LOGIC + // Resolve extension + full path before reading field names + IF String.IsNullOrEmpty(System.IO.Path.GetExtension(cFileName)) + cFileName := System.IO.Path.ChangeExtension(cFileName, ".DBF") + ENDIF + cFileName := System.IO.Path.GetFullPath(cFileName) + IF ! System.IO.File.Exists(cFileName) + Fail(Error{"ADD TABLE: file not found: " + cFileName}) + RETURN FALSE + ENDIF + + // Open the DBF briefly to read physical field names, then close it. + // The full overload below will open it again for the actual DBC work. + LOCAL aFieldNames := List{} AS List + IF CoreDb.UseArea(TRUE, "DBFVFP", cFileName, "_RDTBL_", FALSE, FALSE) + LOCAL oRddTmp := NULL AS OBJECT + IF CoreDb.Info(DBI_RDD_OBJECT, REF oRddTmp) .AND. oRddTmp IS IRdd VAR oRdd + FOR LOCAL nFld := 1 TO oRdd:FieldCount + aFieldNames:Add(oRdd:FieldName(nFld)) + NEXT + ENDIF + CoreDb.CloseArea() + ENDIF + + RETURN AddTable(cFileName, cLongName, aFieldNames) + + /// + /// Implements VFP ADD TABLE / CREATE TABLE DBC registration, + /// accepting a pre-built list of long field names supplied by the caller. + /// + /// + /// This overload is used by CREATE TABLE so that the long field names + /// from the SQL parser (which may exceed 10 characters) are stored in the DBC + /// without re-opening the newly created .DBF. + /// + /// + /// Physical path to the .DBF file (extension optional). The file must exist and + /// must be a free table (empty backlink). + /// + /// + /// Logical (long) table name stored in the DBC OBJECTNAME field. + /// When empty, the filename without extension is used. + /// + /// + /// Long field names in physical column order. For ADD TABLE these are the + /// physical DBF names (≤ 10 chars); for CREATE TABLE they are the parser's + /// long names (may exceed 10 chars). + /// + /// .T. on success; .F. otherwise. + STATIC METHOD AddTable(cFileName AS STRING, cLongName AS STRING, aLongFieldNames AS List) AS LOGIC // ── Validate pre-conditions ──────────────────────────────────────── LOCAL oActiveDbc := DbcManager.ActiveDatabase AS DbcDatabase IF oActiveDbc == NULL_OBJECT @@ -154,7 +205,7 @@ BEGIN NAMESPACE XSharp.RDD cLongName := System.IO.Path.GetFileNameWithoutExtension(cFileName) ENDIF - // ── Open the DBF in a temporary work area in the user data session ── + // ── Open the DBF in a temporary work area ───────────────────────── // IVfpLinked (implemented by DBFVFP) gives us typed access to // DbcName, DbcPosition, and WriteBacklink without a compile-time // reference to XSharp.Rdd. @@ -168,7 +219,6 @@ BEGIN NAMESPACE XSharp.RDD ENDIF nArea := RuntimeState.Workareas:CurrentWorkarea:Area - // Retrieve the RDD object via IVfpLinked LOCAL oRddVal := NULL AS OBJECT IF CoreDb.Info(DBI_RDD_OBJECT, REF oRddVal) .AND. oRddVal IS IVfpLinked VAR vfp oVfp := vfp @@ -186,20 +236,36 @@ BEGIN NAMESPACE XSharp.RDD RETURN FALSE ENDIF - // ── Collect field names via IRdd (physical DBF names). - // These become the DBC OBJECTNAME values for Field records. - LOCAL aFieldNames := List{} AS List - IF oVfp IS IRdd VAR oRdd - LOCAL nFldCount := oRdd:FieldCount AS LONG - FOR LOCAL nFld := 1 TO nFldCount - aFieldNames:Add(oRdd:FieldName(nFld)) - NEXT + // ── Register Table + Field records in the DBC, then write the backlink + lOk := _RegisterTableInDbc(oActiveDbc, cLongName, aLongFieldNames) + + IF lOk + // Back in the user session with area = the DBF. + CoreDb.Select(nArea, OUT NULL) + LOCAL cRelative AS STRING + cRelative := _MakeRelativePath(cFileName, oActiveDbc:FileName) + oVfp:WriteBacklink(cRelative) + // Flush via IRdd — WriteBacklink wrote directly to the stream; + // this ensures any pending record buffer is also committed. + IF oVfp IS IRdd VAR oRddFlush + oRddFlush:Flush() + ENDIF + // Reload the DBC in-memory cache so the new table is immediately visible + oActiveDbc:Reload() ENDIF - // ── Register Table + Field records in the DBC ────────────────────── - // DoForDatabase switches to DbcDataSession; on return we are back in - // the user session with the DBF area still selected. - lOk := DbcManager.DoForDatabase({ => + CoreDb.Select(nArea, OUT NULL) + CoreDb.CloseArea() + RETURN lOk + + /// + /// Core DBC registration logic: appends a Table record and one Field record per + /// entry in to the open DBC work area and commits. + /// Called from both AddTable overloads so the write logic is not duplicated. + /// + PRIVATE STATIC METHOD _RegisterTableInDbc(oActiveDbc AS DbcDatabase, ; + cLongName AS STRING, aFieldNames AS List) AS LOGIC + RETURN DbcManager.DoForDatabase({ => LOCAL nOld AS DWORD CoreDb.Select(oActiveDbc:Area, OUT nOld) @@ -230,27 +296,6 @@ BEGIN NAMESPACE XSharp.RDD RETURN TRUE }) - IF lOk - // ── Write the backlink into the DBF header ───────────────────── - // Back in the user session with area = the DBF. - CoreDb.Select(nArea, OUT NULL) - LOCAL cRelative AS STRING - cRelative := _MakeRelativePath(cFileName, oActiveDbc:FileName) - oVfp:WriteBacklink(cRelative) - // Flush via IRdd — WriteBacklink wrote directly to the stream; - // this ensures any pending record buffer is also committed. - IF oVfp IS IRdd VAR oRddFlush - oRddFlush:Flush() - ENDIF - // Reload the DBC in-memory cache so the new table is immediately visible - oActiveDbc:Reload() - ENDIF - - // Always close the temporary work area - CoreDb.Select(nArea, OUT NULL) - CoreDb.CloseArea() - RETURN lOk - /// /// Compute a relative path from to . /// Returns just the filename when both files share the same directory; diff --git a/src/Runtime/XSharp.Data/Parser/SQLParser.prg b/src/Runtime/XSharp.Data/Parser/SQLParser.prg index a4a9f74801..95efd42207 100644 --- a/src/Runtime/XSharp.Data/Parser/SQLParser.prg +++ b/src/Runtime/XSharp.Data/Parser/SQLParser.prg @@ -394,8 +394,15 @@ PARTIAL CLASS SQLParser SELF:SetError("Expected Column Name", SELF:Lt1 ) RETURN FALSE ENDIF - sqlField:Name := name:Text + // Preserve the full identifier as the long name (DBC OBJECTNAME / alias). + // The physical DBF field name is limited to 10 characters by the VFP spec. + sqlField:Alias := name:Text sqlField:Caption := name:Text + IF name:Text:Length > 10 + sqlField:Name := name:Text:Substring(0, 10) + ELSE + sqlField:Name := name:Text + ENDIF IF !SELF:ExpectAndGet(XTokenType.ID, out oType) SELF:SetError("Expected Column Type", SELF:Lt1 ) RETURN FALSE diff --git a/src/Runtime/XSharp.VFP/SQL/EmbeddedSql.prg b/src/Runtime/XSharp.VFP/SQL/EmbeddedSql.prg index a364a70dbb..2a994b1f5f 100644 --- a/src/Runtime/XSharp.VFP/SQL/EmbeddedSql.prg +++ b/src/Runtime/XSharp.VFP/SQL/EmbeddedSql.prg @@ -10,6 +10,7 @@ using XSharp.RDD using XSharp.RDD.Support using System.IO using System.Linq +using System.Collections.Generic [NeedsAccessToLocals(FALSE)]; FUNCTION __SqlInsertMemVar(sTable as STRING) AS LOGIC // FoxPro opens the table when needed and keeps it open @@ -125,9 +126,15 @@ STATIC CLASS FoxEmbeddedSQL if oTable != NULL local aStruct as ARRAY aStruct := {} + // Build long-name list for DBC registration alongside the struct array + VAR aLongNames := List{} foreach col as FoxColumnContext in oTable:Columns - var aField := {col:Name, ((Char)col:FieldType):ToString(), col:Length, col:Decimals, col:Name, col:Flags} + // Position 5 = DBS_ALIAS: prefer the long field name from the SQL parser; + // fall back to the (possibly truncated) physical name when no alias set. + VAR cFieldAlias := IIF(String.IsNullOrEmpty(col:Alias), col:Name, col:Alias) + var aField := {col:Name, ((Char)col:FieldType):ToString(), col:Length, col:Decimals, cFieldAlias, col:Flags} AAdd(aStruct, aField) + aLongNames:Add(cFieldAlias) next VAR cTable := oTable:Name @@ -141,6 +148,18 @@ STATIC CLASS FoxEmbeddedSQL endif DbCreate(cTable, aStruct, "DBFVFP", TRUE, cAlias) DbCloseArea(cAlias) + + // Register the newly created table in the active DBC when it is a persistent + // (non-cursor, non-FREE) table and a database is currently active. + IF !oTable:IsCursor .AND. !oTable:Free + VAR oActiveDbc := XSharp.RDD.DbcManager.ActiveDatabase + IF oActiveDbc != NULL_OBJECT + VAR cTableLong := IIF(String.IsNullOrEmpty(oTable:LongName), ; + Path.GetFileNameWithoutExtension(cTable), oTable:LongName) + XSharp.RDD.DbcManager.AddTable(cTable, cTableLong, aLongNames) + ENDIF + ENDIF + DbUseArea(TRUE, "DBFVFP", cTable, cAlias, FALSE, FALSE) FOR var nI := 1 to oTable:Columns:Count From 8812180b46b5feb8ef76cd824e0865dfab0e29c6 Mon Sep 17 00:00:00 2001 From: Fabrice Foray Date: Thu, 28 May 2026 12:30:25 +0200 Subject: [PATCH 07/11] [UDC] Fix an error in CLOSE DATABASE syntax --- src/Common/FoxProCmd.xh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Common/FoxProCmd.xh b/src/Common/FoxProCmd.xh index 6b332eef65..bc632bea67 100644 --- a/src/Common/FoxProCmd.xh +++ b/src/Common/FoxProCmd.xh @@ -566,7 +566,7 @@ // Implemented in XSharp.VFP\Database\DatabaseCommands.prg #command CLOSE DATABASES [] => __VFPCloseDatabases( <.all.> ) -#command CLOSE TABLES [ => __VFPCloseTables( <.all.> ) +#command CLOSE TABLES [] => __VFPCloseTables( <.all.> ) // ADD TABLE TableName [NAME LongTableName] // Links an existing free .DBF to the currently active database. From dec71cf0cd4e714af5e15b105c7b70fea4a1cd29 Mon Sep 17 00:00:00 2001 From: Fabrice Foray Date: Thu, 28 May 2026 15:13:54 +0200 Subject: [PATCH 08/11] [DBC Support] Add several Tests in FoxTest project. Fix some related functions --- src/Runtime/XSharp.Core/RDD/DbcSupport.prg | 12 +- src/Runtime/XSharp.Data/Parser/SQLParser.prg | 7 +- src/Runtime/XSharp.Rdd/DbfVfp/DbfVfp.prg | 12 +- src/Runtime/XSharp.VFP/SQL/EmbeddedSql.prg | 20 +- src/Tests/DbcTest/FoxTest.xsproj | 25 +- src/Tests/DbcTest/Program.prg | 44 +-- src/Tests/DbcTest/TestHelper.prg | 111 ++++++ src/Tests/DbcTest/TestRunner.prg | 74 ++++ src/Tests/DbcTest/TestSuite_Dbc.prg | 4 + .../DbcTest/TestSuite_DbcCreateTable.prg | 255 ++++++++++++++ src/Tests/DbcTest/TestSuite_DbcDatabase.prg | 235 +++++++++++++ src/Tests/DbcTest/TestSuite_DbcTable.prg | 319 ++++++++++++++++++ src/Tests/DbcTest/TestSuite_Experimental.prg | 87 +++++ src/Tests/DbcTest/TestSuite_Misc.prg | 110 ++++++ 14 files changed, 1275 insertions(+), 40 deletions(-) create mode 100644 src/Tests/DbcTest/TestHelper.prg create mode 100644 src/Tests/DbcTest/TestRunner.prg create mode 100644 src/Tests/DbcTest/TestSuite_Dbc.prg create mode 100644 src/Tests/DbcTest/TestSuite_DbcCreateTable.prg create mode 100644 src/Tests/DbcTest/TestSuite_DbcDatabase.prg create mode 100644 src/Tests/DbcTest/TestSuite_DbcTable.prg create mode 100644 src/Tests/DbcTest/TestSuite_Experimental.prg create mode 100644 src/Tests/DbcTest/TestSuite_Misc.prg diff --git a/src/Runtime/XSharp.Core/RDD/DbcSupport.prg b/src/Runtime/XSharp.Core/RDD/DbcSupport.prg index fac04b76de..a1073eec6c 100644 --- a/src/Runtime/XSharp.Core/RDD/DbcSupport.prg +++ b/src/Runtime/XSharp.Core/RDD/DbcSupport.prg @@ -1020,11 +1020,13 @@ BEGIN NAMESPACE XSharp.RDD IF iValue != SELF:ObjectID EXIT ENDIF - var oChild := SELF:ReadChild() - IF oChild != NULL_OBJECT - oChild:Read() - oChild:Parent := SELF - aChildren:Add(oChild) + IF ! CoreDb.Deleted() + var oChild := SELF:ReadChild() + IF oChild != NULL_OBJECT + oChild:Read() + oChild:Parent := SELF + aChildren:Add(oChild) + ENDIF ENDIF CoreDb.Skip(1) ENDDO diff --git a/src/Runtime/XSharp.Data/Parser/SQLParser.prg b/src/Runtime/XSharp.Data/Parser/SQLParser.prg index 95efd42207..b07db5aa92 100644 --- a/src/Runtime/XSharp.Data/Parser/SQLParser.prg +++ b/src/Runtime/XSharp.Data/Parser/SQLParser.prg @@ -275,7 +275,12 @@ PARTIAL CLASS SQLParser ENDIF table:Name := tableName if lTable .and. SELF:Expect("NAME") - table:LongName := SELF:ConsumeAndGet():Text + LOCAL cLongName := SELF:ConsumeAndGet():Text AS STRING + IF (cLongName:StartsWith('"') .AND. cLongName:EndsWith('"')) .OR. ; + (cLongName:StartsWith("'") .AND. cLongName:EndsWith("'")) + cLongName := cLongName:Substring(1, cLongName:Length - 2) + ENDIF + table:LongName := cLongName ENDIF IF lTable .and. SELF:Expect("FREE") table:Free := TRUE diff --git a/src/Runtime/XSharp.Rdd/DbfVfp/DbfVfp.prg b/src/Runtime/XSharp.Rdd/DbfVfp/DbfVfp.prg index 20f82d89b7..46474c6c46 100644 --- a/src/Runtime/XSharp.Rdd/DbfVfp/DbfVfp.prg +++ b/src/Runtime/XSharp.Rdd/DbfVfp/DbfVfp.prg @@ -276,8 +276,14 @@ CLASS DBFVFP INHERIT DBFCDX IMPLEMENTS IVfpLinked VAR cPath := System.IO.Path.GetDirectoryName(SELF:FileName) cDbcFile := System.IO.Path.Combine(cPath, cDbcFile) ENDIF - Dbc.Open(cDbcFile, TRUE, TRUE, FALSE) + // Check if the DBC is already open in DbcManager before trying to open the file. + // Opening it again would conflict with an exclusively-locked DBC in DbcDataSession + // (the structural .DCX is opened with FileShare.None and can't be reopened). VAR oDb := Dbc.FindDatabase(cDbcFile) + IF oDb == NULL + Dbc.Open(cDbcFile, TRUE, TRUE, FALSE) + oDb := Dbc.FindDatabase(cDbcFile) + ENDIF IF oDb != NULL var base := System.IO.Path.GetFileNameWithoutExtension(SELF:FileName) var oTable := oDb:FindTable(System.IO.Path.GetFileName(base)) @@ -304,6 +310,10 @@ CLASS DBFVFP INHERIT DBFCDX IMPLEMENTS IVfpLinked ENDIF ENDIF ENDIF + // Clear any error set during DBC lookup (failed Dbc.Open or LoadChildren). + // We must not let it bleed into the OpenProductionIndex error-check in + // DBFVFP.Open / DBFCDX.Open — reading long field names is best-effort. + RuntimeState.LastRddError := NULL /// diff --git a/src/Runtime/XSharp.VFP/SQL/EmbeddedSql.prg b/src/Runtime/XSharp.VFP/SQL/EmbeddedSql.prg index 2a994b1f5f..5d1fa7468c 100644 --- a/src/Runtime/XSharp.VFP/SQL/EmbeddedSql.prg +++ b/src/Runtime/XSharp.VFP/SQL/EmbeddedSql.prg @@ -147,6 +147,17 @@ STATIC CLASS FoxEmbeddedSQL DbCloseArea(cAlias) endif DbCreate(cTable, aStruct, "DBFVFP", TRUE, cAlias) + // Compute the full absolute path from the SQL-parsed name and SET DEFAULT. + // We cannot rely on FPathName() here because subsequent internal opens + // (AddTable, Reload) shift the current work area before DbUseArea is called. + LOCAL cFullPath := cTable AS STRING + IF !Path.IsPathRooted(cFullPath) + LOCAL getDefault := SetDefault() AS STRING + cFullPath := Path.Combine(getDefault , cFullPath) + ENDIF + IF String.IsNullOrEmpty(Path.GetExtension(cFullPath)) + cFullPath := cFullPath + ".DBF" + ENDIF DbCloseArea(cAlias) // Register the newly created table in the active DBC when it is a persistent @@ -155,13 +166,14 @@ STATIC CLASS FoxEmbeddedSQL VAR oActiveDbc := XSharp.RDD.DbcManager.ActiveDatabase IF oActiveDbc != NULL_OBJECT VAR cTableLong := IIF(String.IsNullOrEmpty(oTable:LongName), ; - Path.GetFileNameWithoutExtension(cTable), oTable:LongName) - XSharp.RDD.DbcManager.AddTable(cTable, cTableLong, aLongNames) + Path.GetFileNameWithoutExtension(cFullPath), oTable:LongName) + XSharp.RDD.DbcManager.AddTable(cFullPath, cTableLong, aLongNames) ENDIF ENDIF - DbUseArea(TRUE, "DBFVFP", cTable, cAlias, FALSE, FALSE) - + // Use the resolved absolute path and shared mode so the open succeeds + // even when an exclusively-locked DBC is active in DbcDataSession. + LOCAL lDbOpen := DbUseArea(TRUE, "DBFVFP", cFullPath, cAlias, TRUE, FALSE) AS LOGIC FOR var nI := 1 to oTable:Columns:Count var oCol := oTable:Columns[nI-1] DbFieldInfo(DBS_CAPTION, nI, oCol:Caption) diff --git a/src/Tests/DbcTest/FoxTest.xsproj b/src/Tests/DbcTest/FoxTest.xsproj index c854b52e6b..bfa75e9a29 100644 --- a/src/Tests/DbcTest/FoxTest.xsproj +++ b/src/Tests/DbcTest/FoxTest.xsproj @@ -1,4 +1,4 @@ - + @@ -85,6 +85,27 @@ Code + + Code + + + Code + + + Code + + + Code + + + Code + + + Code + + + Code + @@ -137,4 +158,4 @@ - \ No newline at end of file + diff --git a/src/Tests/DbcTest/Program.prg b/src/Tests/DbcTest/Program.prg index 4e4972e0fc..707ac2515b 100644 --- a/src/Tests/DbcTest/Program.prg +++ b/src/Tests/DbcTest/Program.prg @@ -1,29 +1,19 @@ -Using System -Using System.Collections.Generic -Using System.Linq -Using System.Text +USING System +USING System.IO -Function Start() As Void Strict - LOCAL u AS USUAL -PRIVATE p -try -u := Today() -p := Today() +FUNCTION Start() AS VOID STRICT + LOCAL cDataPath AS STRING + cDataPath := Path.Combine(DataPath(), "DbcTest") + IF !System.IO.Directory.Exists(cDataPath) + System.IO.Directory.CreateDirectory(cDataPath) + ENDIF + TestRunner.RunAll(cDataPath) + ? "Press any key..." + Console.ReadKey() + + + // Returns the path of the test data folder (same folder as the exe) +FUNCTION DataPath() AS STRING + RETURN System.IO.Path.GetDirectoryName(System.Reflection.Assembly.GetExecutingAssembly():Location) +END FUNCTION -? GoMonth(u,1) // error XS0121 -? GoMonth(p,1) // error XS0121 - ? Quarter(u, 1) - ? Week(u,1) - ? Week(u,2) - ? Week(u,3) - ? Dmy(u) - ? Mdy(u) - u := "abc" - //? Mdy(u) - //? Week(u,3) - //? GoMonth(u,1) // error XS0121 - ? Quarter(u, 1) -catch e as exception - ? e:ToString() -end try - wait diff --git a/src/Tests/DbcTest/TestHelper.prg b/src/Tests/DbcTest/TestHelper.prg new file mode 100644 index 0000000000..7eb9c0fe29 --- /dev/null +++ b/src/Tests/DbcTest/TestHelper.prg @@ -0,0 +1,111 @@ +// +// TestHelper.prg +// +// Shared assertion, cleanup, and setup helpers used by every TestSuite_* class. +// All methods are PUBLIC STATIC so any suite can call them directly. +// + +USING System +USING System.IO +USING XSharp.RDD + +STATIC CLASS TestHelper + + // ----------------------------------------------------------------------- + // Assertion helpers + // ----------------------------------------------------------------------- + + PUBLIC STATIC METHOD AssertEqual(uActual AS USUAL, uExpected AS USUAL, cMsg AS STRING) AS LOGIC + IF uActual != uExpected + ? " Expected: <" + Str(uExpected) + "> Got: <" + Str(uActual) + "> (" + cMsg + ")" + RETURN FALSE + ENDIF + RETURN TRUE + END METHOD + + PUBLIC STATIC METHOD AssertTrue(lCond AS LOGIC, cMsg AS STRING) AS LOGIC + IF !lCond + ? " Assertion failed: " + cMsg + RETURN FALSE + ENDIF + RETURN TRUE + END METHOD + + // Install a no-op error block and return the previous one so the caller + // can restore it in a FINALLY block. + PUBLIC STATIC METHOD InstallSwallowErrorBlock() AS USUAL + RETURN ErrorBlock({|oErr| 0}) + END METHOD + + // ----------------------------------------------------------------------- + // DBC file helpers + // ----------------------------------------------------------------------- + + // Delete .DBC / .DCT / .DCX companion files for a database at cBasePath (no extension). + PUBLIC STATIC METHOD CleanupDb(cBasePath AS STRING) AS VOID + LOCAL aExts := { ".DBC", ".DCT", ".DCX" } AS STRING[] + FOREACH VAR cExt IN aExts + LOCAL cFile := cBasePath + cExt AS STRING + IF File.Exists(cFile) + TRY + File.Delete(cFile) + CATCH AS Exception + NOP + END TRY + ENDIF + NEXT + END METHOD + + // Delete .DBF / .FPT / .CDX companion files for a table at cBasePath (no extension). + PUBLIC STATIC METHOD CleanupTable(cBasePath AS STRING) AS VOID + LOCAL aExts := { ".DBF", ".FPT", ".CDX" } AS STRING[] + FOREACH VAR cExt IN aExts + LOCAL cFile := cBasePath + cExt AS STRING + IF File.Exists(cFile) + TRY + File.Delete(cFile) + CATCH AS Exception + NOP + END TRY + ENDIF + NEXT + END METHOD + + // Create a simple two-field free DBF at cBasePath (no extension). + // Uses DBFVFP driver so it is compatible with DBC link operations. + // We deactivate any open DBC before calling DbCreate so the DBFVFP driver + // does not auto-link the new file to the active database (VFP behaviour). + // DbCreate also leaves the file open; we close it so ADD TABLE can open it. + PUBLIC STATIC METHOD CreateFreeTable(cBasePath AS STRING) AS LOGIC + LOCAL oActive := Dbc.GetCurrent() AS DbcDatabase + IF oActive != NULL_OBJECT + Dbc.Select() + ENDIF + TRY + LOCAL aStruct AS ARRAY + aStruct := {{ "ID", "I", 4, 0 }, { "NAME", "C", 20, 0 }} + LOCAL lOk := DbCreate(cBasePath + ".DBF", aStruct, "DBFVFP") AS LOGIC + IF lOk + DbCloseArea() + ENDIF + RETURN lOk + FINALLY + IF oActive != NULL_OBJECT + Dbc.Select(oActive:Name) + ENDIF + END TRY + END METHOD + + // Create, open, and activate a database at cBasePath (no extension). + // Returns .T. on success. The DBC is left open and active on return. + PUBLIC STATIC METHOD OpenActiveDb(cBasePath AS STRING) AS LOGIC + Dbc.Create(cBasePath) + LOCAL lOk := Dbc.Open(cBasePath, FALSE, FALSE, FALSE) AS LOGIC // exclusive so Delete/FieldPut work without explicit locking + IF lOk + LOCAL cName := Path.GetFileNameWithoutExtension(cBasePath):ToUpper() AS STRING + Dbc.Select(cName) + ENDIF + RETURN lOk + END METHOD + +END CLASS diff --git a/src/Tests/DbcTest/TestRunner.prg b/src/Tests/DbcTest/TestRunner.prg new file mode 100644 index 0000000000..ca5feeb183 --- /dev/null +++ b/src/Tests/DbcTest/TestRunner.prg @@ -0,0 +1,74 @@ +// +// TestRunner.prg +// +// Test orchestrator: calls each TestSuite_*.RunAll() in order and prints +// the grand total. Individual test methods live in the TestSuite_* files. +// +// Suite layout +// ───────────────────────────────────────────────────── +// TestSuite_Misc — miscellaneous smoke tests (date/string functions on USUAL/PRIVATE) +// TestSuite_DbcDatabase — database-level operations (CREATE/OPEN/CLOSE DATABASE, SET DATABASE TO) +// TestSuite_DbcTable — table-level operations (ADD/REMOVE/RENAME TABLE) +// TestSuite_DbcCreateTable — CREATE TABLE with DBC (auto-register, FREE, long names, NAME clause) +// ───────────────────────────────────────────────────── +// +// TestSuite_Experimental — sandbox (not counted); call is commented out below. +// + +USING System + + +STATIC CLASS TestRunner + + PRIVATE STATIC _nPass AS INT + PRIVATE STATIC _nFail AS INT + + // ----------------------------------------------------------------------- + // Entry point + // ----------------------------------------------------------------------- + + PUBLIC STATIC METHOD RunAll(cDataPath AS STRING) AS LOGIC + _nPass := 0 + _nFail := 0 + + LOCAL cbPrev := ErrorBlock({|oErr| MyErrorHandler(oErr)}) AS USUAL + + ? "=== XSharp DBC Tests ===" + + // Experimental sandbox — uncomment while designing new tests; + // re-comment before committing so it never pollutes the official total. + //TestSuite_Experimental.RunAll(cDataPath) + //_nPass += TestSuite_Experimental.PassCount + //_nFail += TestSuite_Experimental.FailCount + + TestSuite_Misc.RunAll(cDataPath) + _nPass += TestSuite_Misc.PassCount + _nFail += TestSuite_Misc.FailCount + + TestSuite_DbcDatabase.RunAll(cDataPath) + _nPass += TestSuite_DbcDatabase.PassCount + _nFail += TestSuite_DbcDatabase.FailCount + + TestSuite_DbcTable.RunAll(cDataPath) + _nPass += TestSuite_DbcTable.PassCount + _nFail += TestSuite_DbcTable.FailCount + + TestSuite_DbcCreateTable.RunAll(cDataPath) + _nPass += TestSuite_DbcCreateTable.PassCount + _nFail += TestSuite_DbcCreateTable.FailCount + + ErrorBlock(cbPrev) + + ? + ? "=== Results: " + _nPass:ToString() + " passed, " + _nFail:ToString() + " failed ===" + RETURN _nFail == 0 + END METHOD + +END CLASS + + +FUNCTION MyErrorHandler(oError) + ? oError:Message + ? oError:Source + ? oError:StackTrace + BREAK oError diff --git a/src/Tests/DbcTest/TestSuite_Dbc.prg b/src/Tests/DbcTest/TestSuite_Dbc.prg new file mode 100644 index 0000000000..8285754857 --- /dev/null +++ b/src/Tests/DbcTest/TestSuite_Dbc.prg @@ -0,0 +1,4 @@ +// This file has been split into: +// TestSuite_DbcDatabase.prg — CREATE/OPEN/CLOSE DATABASE, SET DATABASE TO +// TestSuite_DbcTable.prg — ADD/REMOVE/RENAME TABLE +// It is no longer compiled (removed from FoxTest.xsproj). diff --git a/src/Tests/DbcTest/TestSuite_DbcCreateTable.prg b/src/Tests/DbcTest/TestSuite_DbcCreateTable.prg new file mode 100644 index 0000000000..9b439fb673 --- /dev/null +++ b/src/Tests/DbcTest/TestSuite_DbcCreateTable.prg @@ -0,0 +1,255 @@ +// +// TestSuite_DbcCreateTable.prg +// +// Tests for CREATE TABLE with an active DBC: +// auto-registration, FREE keyword, long field names, NAME clause, +// no active DBC, table left open after creation. +// + +USING System +USING System.IO +USING XSharp.RDD +#include "E:\XSharp\dev\XSharp\src\Common\FoxProCmd.xh" + +STATIC CLASS TestSuite_DbcCreateTable + + PRIVATE STATIC _nPass AS INT + PRIVATE STATIC _nFail AS INT + PRIVATE STATIC _cDataPath AS STRING + + PUBLIC STATIC PROPERTY PassCount AS INT + GET + RETURN _nPass + END GET + END PROPERTY + + PUBLIC STATIC PROPERTY FailCount AS INT + GET + RETURN _nFail + END GET + END PROPERTY + + PUBLIC STATIC METHOD RunAll(cDataPath AS STRING) AS LOGIC + _nPass := 0 + _nFail := 0 + _cDataPath := cDataPath + + SET(Set.Default, cDataPath) + + ? + ? " --- TestSuite_DbcCreateTable ---" + + Safe("CREATE TABLE auto-registers in active DBC", {|| TestCreateTableRegisters()}) + Safe("CREATE TABLE leaves table open", {|| TestCreateTableIsOpen()}) + Safe("CREATE TABLE FREE does not register in DBC", {|| TestCreateTableFreeNotRegistered()}) + Safe("CREATE TABLE without active DBC creates file only", {|| TestCreateTableNoActiveDbc()}) + Safe("CREATE TABLE stores long field names in DBC", {|| TestCreateTableLongFieldNames()}) + Safe("CREATE TABLE NAME stores long table name in DBC", {|| TestCreateTableWithName()}) + Safe("CREATE TABLE with quoted full path", {|| TestCreateTableQuotedPath()}) + Safe("CREATE TABLE with PRIVATE variable path", {|| TestCreateTablePrivatePath()}) + + RETURN _nFail == 0 + END METHOD + + // ----------------------------------------------------------------------- + // Tests + // ----------------------------------------------------------------------- + + PRIVATE STATIC METHOD TestCreateTableRegisters() AS LOGIC + LOCAL cDb := DbPath("crt_reg") AS STRING + LOCAL cTbl := DbPath("crt_reg_t") AS STRING + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + TRY + TestHelper.OpenActiveDb(cDb) + CREATE TABLE crt_reg_t (Id I, Name C(20)) + LOCAL oDb := Dbc.GetCurrent() AS DbcDatabase + RETURN AssertTrue(oDb:FindTable("crt_reg_t") != NULL_OBJECT, "Table must be registered in DBC after CREATE TABLE") + FINALLY + CloseTable(cTbl) + CLOSE DATABASES ALL + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + END TRY + END METHOD + + PRIVATE STATIC METHOD TestCreateTableIsOpen() AS LOGIC + LOCAL cDb := DbPath("crt_open") AS STRING + LOCAL cTbl := DbPath("crt_open_t") AS STRING + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + TRY + TestHelper.OpenActiveDb(cDb) + CREATE TABLE crt_open_t (Id I, Name C(20)) + // Used() + Alias() are reliable; DbUsed() uses a different lookup path and + // doesn't find the area opened via DbUseArea inside CreateTableCursor. + RETURN AssertTrue(Used() .AND. Alias() == "CRT_OPEN_T", "Table must be open with alias CRT_OPEN_T after CREATE TABLE") + FINALLY + CloseTable(cTbl) + CLOSE DATABASES ALL + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + END TRY + END METHOD + + PRIVATE STATIC METHOD TestCreateTableFreeNotRegistered() AS LOGIC + LOCAL cDb := DbPath("crt_free") AS STRING + LOCAL cTbl := DbPath("crt_free_t") AS STRING + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + TRY + TestHelper.OpenActiveDb(cDb) + CREATE TABLE crt_free_t FREE (Id I, Name C(20)) + LOCAL oDb := Dbc.GetCurrent() AS DbcDatabase + RETURN AssertTrue(File(cTbl + ".DBF"), ".DBF file must exist after CREATE TABLE FREE") ; + .AND. AssertTrue(oDb:FindTable("crt_free_t") == NULL_OBJECT, "FREE table must NOT be registered in DBC") + FINALLY + CloseTable(cTbl) + CLOSE DATABASES ALL + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + END TRY + END METHOD + + PRIVATE STATIC METHOD TestCreateTableNoActiveDbc() AS LOGIC + LOCAL cTbl := DbPath("crt_nodb_t") AS STRING + TestHelper.CleanupTable(cTbl) + TRY + Dbc.Select() + CREATE TABLE crt_nodb_t (Id I, Name C(20)) + RETURN AssertTrue(File(cTbl + ".DBF"), ".DBF file must exist when CREATE TABLE is used without an active DBC") + FINALLY + CloseTable(cTbl) + TestHelper.CleanupTable(cTbl) + END TRY + END METHOD + + PRIVATE STATIC METHOD TestCreateTableLongFieldNames() AS LOGIC + LOCAL cDb := DbPath("crt_long") AS STRING + LOCAL cTbl := DbPath("crt_long_t") AS STRING + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + TRY + TestHelper.OpenActiveDb(cDb) + CREATE TABLE crt_long_t (CustomerLastName C(50), OrderDate D) + LOCAL oDb := Dbc.GetCurrent() AS DbcDatabase + LOCAL oTable := oDb:FindTable("crt_long_t") AS DbcTable + IF !AssertTrue(oTable != NULL_OBJECT, "Table must be registered in DBC") ; RETURN FALSE ; ENDIF + LOCAL lFirstFieldLong := oTable:Fields:Count >= 1 .AND. oTable:Fields[0]:ObjectName:Length > 10 AS LOGIC + RETURN AssertTrue(lFirstFieldLong, "First field name in DBC must be the full long name (> 10 chars)") ; + .AND. AssertEqual(oTable:Fields[0]:ObjectName, "CustomerLastName", "Full long field name must be stored in DBC") + FINALLY + CloseTable(cTbl) + CLOSE DATABASES ALL + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + END TRY + END METHOD + + PRIVATE STATIC METHOD TestCreateTableWithName() AS LOGIC + LOCAL cDb := DbPath("crt_name") AS STRING + LOCAL cTbl := DbPath("crt_name_t") AS STRING + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + TRY + TestHelper.OpenActiveDb(cDb) + CREATE TABLE crt_name_t NAME "MyLongTableName" (Id I) + LOCAL oDb := Dbc.GetCurrent() AS DbcDatabase + RETURN AssertTrue(oDb:FindTable("MyLongTableName") != NULL_OBJECT, "Table must be registered under its long NAME in DBC") + FINALLY + CloseTable(cTbl) + CLOSE DATABASES ALL + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + END TRY + END METHOD + + // STRING_CONST path: ParseTableName accepts a quoted string, so a full Windows path + // avoids the colon-as-alias-separator ambiguity. The UDC stringifies the quotes. + PRIVATE STATIC METHOD TestCreateTableQuotedPath() AS LOGIC + LOCAL cTbl := DbPath("crt_qpath_t") AS STRING + TestHelper.CleanupTable(cTbl) + // Build quoted SQL dynamically — the parser treats the quoted token as STRING_CONST. + // To be sure that that if we had a fullPath in the CREATE TABLE command it works + LOCAL cSql := 'CREATE TABLE "' + cTbl + '" FREE (Id I, Name C(20))' AS STRING + TRY + Dbc.Select() + __SqlCreateTable(cSql) + RETURN AssertTrue(File(cTbl + ".DBF"), ".DBF must exist when created with a quoted full path") + FINALLY + CloseTable(cTbl) + TestHelper.CleanupTable(cTbl) + END TRY + END METHOD + + // PRIVATE variable path: ParseTableName calls __VarGetSafe(name) for the (varName) syntax. + // This lets CREATE TABLE use a full runtime path via the UDC — the variable must be + // PRIVATE or PUBLIC, not LOCAL, because __VarGetSafe looks up the memvar stack. + PRIVATE STATIC METHOD TestCreateTablePrivatePath() AS LOGIC + LOCAL cTbl := DbPath("crt_ppath_t") AS STRING + TestHelper.CleanupTable(cTbl) + TRY + Dbc.Select() + PRIVATE cPrivatePath AS STRING + cPrivatePath := cTbl + CREATE TABLE (cPrivatePath) FREE (Id I, Name C(20)) + RETURN AssertTrue(File(cTbl + ".DBF"), ".DBF must exist when created via PRIVATE variable path") + FINALLY + CloseTable(cTbl) + TestHelper.CleanupTable(cTbl) + END TRY + END METHOD + + // ----------------------------------------------------------------------- + // Helpers + // ----------------------------------------------------------------------- + + PRIVATE STATIC METHOD DbPath(cName AS STRING) AS STRING + RETURN Path.Combine(_cDataPath, cName) + END METHOD + + // Close the work area opened by CREATE TABLE. + // X# stores the alias exactly as passed to DbUseArea (EmbeddedSql uses + // filename-without-extension as-is, lowercase for relative names), so + // try both cases to be safe. + PRIVATE STATIC METHOD CloseTable(cBasePath AS STRING) AS VOID + LOCAL cAlias := Path.GetFileNameWithoutExtension(cBasePath) AS STRING + IF DbUsed(cAlias) + DbCloseArea(cAlias) + ELSEIF DbUsed(cAlias:ToUpper()) + DbCloseArea(cAlias:ToUpper()) + ENDIF + END METHOD + + // ----------------------------------------------------------------------- + // Infrastructure + // ----------------------------------------------------------------------- + + PRIVATE STATIC METHOD Safe(cName AS STRING, cbTest AS USUAL) AS VOID + LOCAL lOk := FALSE AS LOGIC + TRY + lOk := (LOGIC) Eval(cbTest) + CATCH ex AS Exception + ? " [FAIL] " + cName + ? " EXCEPTION: " + ex:Message + _nFail += 1 + RETURN + END TRY + IF lOk + _nPass += 1 + ? " [PASS] " + cName + ELSE + _nFail += 1 + ? " [FAIL] " + cName + ENDIF + END METHOD + + PRIVATE STATIC METHOD AssertEqual(uActual AS USUAL, uExpected AS USUAL, cMsg AS STRING) AS LOGIC + RETURN TestHelper.AssertEqual(uActual, uExpected, cMsg) + END METHOD + + PRIVATE STATIC METHOD AssertTrue(lCond AS LOGIC, cMsg AS STRING) AS LOGIC + RETURN TestHelper.AssertTrue(lCond, cMsg) + END METHOD + +END CLASS diff --git a/src/Tests/DbcTest/TestSuite_DbcDatabase.prg b/src/Tests/DbcTest/TestSuite_DbcDatabase.prg new file mode 100644 index 0000000000..66187dd50f --- /dev/null +++ b/src/Tests/DbcTest/TestSuite_DbcDatabase.prg @@ -0,0 +1,235 @@ +// +// TestSuite_DbcDatabase.prg +// +// Tests for database-level DBC operations: +// CREATE DATABASE, OPEN DATABASE, SET DATABASE TO, CLOSE DATABASES +// + +USING System +USING System.IO +USING XSharp.RDD +#include "E:\XSharp\dev\XSharp\src\Common\FoxProCmd.xh" + +STATIC CLASS TestSuite_DbcDatabase + + PRIVATE STATIC _nPass AS INT + PRIVATE STATIC _nFail AS INT + PRIVATE STATIC _cDataPath AS STRING + + PUBLIC STATIC PROPERTY PassCount AS INT + GET + RETURN _nPass + END GET + END PROPERTY + + PUBLIC STATIC PROPERTY FailCount AS INT + GET + RETURN _nFail + END GET + END PROPERTY + + PUBLIC STATIC METHOD RunAll(cDataPath AS STRING) AS LOGIC + _nPass := 0 + _nFail := 0 + _cDataPath := cDataPath + + SET(Set.Default, cDataPath) + + ? + ? " --- TestSuite_DbcDatabase ---" + + Safe("CREATE DATABASE creates .DBC file on disk", {|| TestCreateCreatesFile()}) + Safe("CREATE DATABASE does not open the database", {|| TestCreateDoesNotOpen()}) + Safe("OPEN DATABASE registers the database as used", {|| TestOpenIsUsed()}) + Safe("OPEN DATABASE does not activate the database", {|| TestOpenDoesNotActivate()}) + Safe("OPEN DATABASE EXCLUSIVE opens successfully", {|| TestOpenExclusive()}) + Safe("OPEN DATABASE NOUPDATE opens successfully", {|| TestOpenReadOnly()}) + Safe("OPEN DATABASE twice returns FALSE", {|| TestOpenAlreadyOpen()}) + Safe("OPEN DATABASE non-existent file returns FALSE", {|| TestOpenNonExistent()}) + Safe("OPEN DATABASE VALIDATE on valid DBC succeeds", {|| TestOpenValidate()}) + Safe("SET DATABASE TO activates the database", {|| TestSetDatabaseActivates()}) + Safe("CLOSE DATABASES closes and deactivates", {|| TestCloseDatabasesDeactivates()}) + + RETURN _nFail == 0 + END METHOD + + // ----------------------------------------------------------------------- + // Tests + // ----------------------------------------------------------------------- + + PRIVATE STATIC METHOD TestCreateCreatesFile() AS LOGIC + LOCAL cPath := DbPath("create1") AS STRING + TestHelper.CleanupDb(cPath) + TRY + CREATE DATABASE (cPath) + RETURN AssertTrue(File(cPath + ".DBC"), ".DBC file must exist after CREATE DATABASE") + FINALLY + TestHelper.CleanupDb(cPath) + END TRY + END METHOD + + PRIVATE STATIC METHOD TestCreateDoesNotOpen() AS LOGIC + LOCAL cPath := DbPath("create2") AS STRING + TestHelper.CleanupDb(cPath) + TRY + CREATE DATABASE (cPath) + RETURN AssertTrue(!Dbc.IsUsed("CREATE2"), "CREATE DATABASE must not register the database as open") + FINALLY + TestHelper.CleanupDb(cPath) + END TRY + END METHOD + + PRIVATE STATIC METHOD TestOpenIsUsed() AS LOGIC + LOCAL cPath := DbPath("open1") AS STRING + TestHelper.CleanupDb(cPath) + TRY + CREATE DATABASE (cPath) + OPEN DATABASE (cPath) + RETURN AssertTrue(Dbc.IsUsed("OPEN1"), "OPEN DATABASE must register the database as used") + FINALLY + CLOSE DATABASES ALL + TestHelper.CleanupDb(cPath) + END TRY + END METHOD + + PRIVATE STATIC METHOD TestOpenDoesNotActivate() AS LOGIC + LOCAL cPath := DbPath("open2") AS STRING + TestHelper.CleanupDb(cPath) + TRY + CREATE DATABASE (cPath) + OPEN DATABASE (cPath) + RETURN AssertTrue(Dbc.GetCurrent() == NULL_OBJECT, "OPEN DATABASE must not activate the database") + FINALLY + CLOSE DATABASES ALL + TestHelper.CleanupDb(cPath) + END TRY + END METHOD + + PRIVATE STATIC METHOD TestOpenExclusive() AS LOGIC + LOCAL cPath := DbPath("openex") AS STRING + TestHelper.CleanupDb(cPath) + TRY + CREATE DATABASE (cPath) + OPEN DATABASE (cPath) EXCLUSIVE + RETURN AssertTrue(Dbc.IsUsed("OPENEX"), "OPEN DATABASE EXCLUSIVE must register the database as used") + FINALLY + CLOSE DATABASES ALL + TestHelper.CleanupDb(cPath) + END TRY + END METHOD + + PRIVATE STATIC METHOD TestOpenReadOnly() AS LOGIC + LOCAL cPath := DbPath("openro") AS STRING + TestHelper.CleanupDb(cPath) + TRY + CREATE DATABASE (cPath) + OPEN DATABASE (cPath) NOUPDATE + RETURN AssertTrue(Dbc.IsUsed("OPENRO"), "OPEN DATABASE NOUPDATE must register the database as used") + FINALLY + CLOSE DATABASES ALL + TestHelper.CleanupDb(cPath) + END TRY + END METHOD + + PRIVATE STATIC METHOD TestOpenAlreadyOpen() AS LOGIC + LOCAL cPath := DbPath("opendup") AS STRING + TestHelper.CleanupDb(cPath) + TRY + CREATE DATABASE (cPath) + OPEN DATABASE (cPath) + LOCAL lSecond := Dbc.Open(cPath + ".DBC", TRUE, FALSE, FALSE) AS LOGIC + RETURN AssertTrue(!lSecond, "OPEN DATABASE on an already-open DBC must return FALSE") ; + .AND. AssertTrue(Dbc.IsUsed("OPENDUP"), "First open must still be registered") + FINALLY + CLOSE DATABASES ALL + TestHelper.CleanupDb(cPath) + END TRY + END METHOD + + PRIVATE STATIC METHOD TestOpenNonExistent() AS LOGIC + LOCAL cPath := DbPath("doesnotexist") AS STRING + TestHelper.CleanupDb(cPath) + LOCAL lResult := Dbc.Open(cPath + ".DBC", TRUE, FALSE, FALSE) AS LOGIC + RETURN AssertTrue(!lResult, "OPEN DATABASE on a non-existent file must return FALSE") + END METHOD + + PRIVATE STATIC METHOD TestOpenValidate() AS LOGIC + LOCAL cPath := DbPath("openval") AS STRING + TestHelper.CleanupDb(cPath) + TRY + CREATE DATABASE (cPath) + OPEN DATABASE (cPath) VALIDATE + RETURN AssertTrue(Dbc.IsUsed("OPENVAL"), "OPEN DATABASE VALIDATE on a valid DBC must succeed") + FINALLY + CLOSE DATABASES ALL + TestHelper.CleanupDb(cPath) + END TRY + END METHOD + + PRIVATE STATIC METHOD TestSetDatabaseActivates() AS LOGIC + LOCAL cPath := DbPath("setdb1") AS STRING + TestHelper.CleanupDb(cPath) + TRY + CREATE DATABASE (cPath) + OPEN DATABASE (cPath) + SET DATABASE TO SETDB1 + LOCAL oCurrent := Dbc.GetCurrent() AS DbcDatabase + RETURN AssertTrue(oCurrent != NULL_OBJECT, "SET DATABASE TO must activate the database") ; + .AND. AssertEqual(oCurrent:Name, "SETDB1", "Active database name must match") + FINALLY + CLOSE DATABASES ALL + TestHelper.CleanupDb(cPath) + END TRY + END METHOD + + PRIVATE STATIC METHOD TestCloseDatabasesDeactivates() AS LOGIC + LOCAL cPath := DbPath("close1") AS STRING + TestHelper.CleanupDb(cPath) + TRY + CREATE DATABASE (cPath) + OPEN DATABASE (cPath) + SET DATABASE TO CLOSE1 + CLOSE DATABASES + RETURN AssertTrue(!Dbc.IsUsed("CLOSE1"), "CLOSE DATABASES must unregister the database") ; + .AND. AssertTrue(Dbc.GetCurrent() == NULL_OBJECT, "CLOSE DATABASES must deactivate the database") + FINALLY + TestHelper.CleanupDb(cPath) + END TRY + END METHOD + + // ----------------------------------------------------------------------- + // Infrastructure + // ----------------------------------------------------------------------- + + PRIVATE STATIC METHOD DbPath(cName AS STRING) AS STRING + RETURN Path.Combine(_cDataPath, cName) + END METHOD + + PRIVATE STATIC METHOD Safe(cName AS STRING, cbTest AS USUAL) AS VOID + LOCAL lOk := FALSE AS LOGIC + TRY + lOk := (LOGIC) Eval(cbTest) + CATCH ex AS Exception + ? " [FAIL] " + cName + ? " EXCEPTION: " + ex:Message + _nFail += 1 + RETURN + END TRY + IF lOk + _nPass += 1 + ? " [PASS] " + cName + ELSE + _nFail += 1 + ? " [FAIL] " + cName + ENDIF + END METHOD + + PRIVATE STATIC METHOD AssertEqual(uActual AS USUAL, uExpected AS USUAL, cMsg AS STRING) AS LOGIC + RETURN TestHelper.AssertEqual(uActual, uExpected, cMsg) + END METHOD + + PRIVATE STATIC METHOD AssertTrue(lCond AS LOGIC, cMsg AS STRING) AS LOGIC + RETURN TestHelper.AssertTrue(lCond, cMsg) + END METHOD + +END CLASS diff --git a/src/Tests/DbcTest/TestSuite_DbcTable.prg b/src/Tests/DbcTest/TestSuite_DbcTable.prg new file mode 100644 index 0000000000..a7682b7baa --- /dev/null +++ b/src/Tests/DbcTest/TestSuite_DbcTable.prg @@ -0,0 +1,319 @@ +// +// TestSuite_DbcTable.prg +// +// Tests for table-level DBC operations: +// ADD TABLE [NAME], REMOVE TABLE [DELETE], RENAME TABLE +// + +USING System +USING System.IO +USING XSharp.RDD +#include "E:\XSharp\dev\XSharp\src\Common\FoxProCmd.xh" + +STATIC CLASS TestSuite_DbcTable + + PRIVATE STATIC _nPass AS INT + PRIVATE STATIC _nFail AS INT + PRIVATE STATIC _cDataPath AS STRING + + PUBLIC STATIC PROPERTY PassCount AS INT + GET + RETURN _nPass + END GET + END PROPERTY + + PUBLIC STATIC PROPERTY FailCount AS INT + GET + RETURN _nFail + END GET + END PROPERTY + + PUBLIC STATIC METHOD RunAll(cDataPath AS STRING) AS LOGIC + _nPass := 0 + _nFail := 0 + _cDataPath := cDataPath + + SET(Set.Default, cDataPath) + + ? + ? " --- TestSuite_DbcTable ---" + + // ADD TABLE + Safe("ADD TABLE registers table in DBC", {|| TestAddTableRegisters()}) + Safe("ADD TABLE NAME registers long name", {|| TestAddTableWithLongName()}) + Safe("ADD TABLE registers fields in DBC", {|| TestAddTableRegistersFields()}) + Safe("ADD TABLE non-existent file returns FALSE", {|| TestAddTableNonExistent()}) + Safe("ADD TABLE without active DB returns FALSE", {|| TestAddTableNoActiveDb()}) + + // REMOVE TABLE + Safe("REMOVE TABLE unregisters from DBC", {|| TestRemoveTableUnregisters()}) + Safe("REMOVE TABLE keeps file on disk by default", {|| TestRemoveTableKeepsFile()}) + Safe("REMOVE TABLE DELETE deletes file from disk", {|| TestRemoveTableDelete()}) + Safe("REMOVE TABLE unknown name returns FALSE", {|| TestRemoveTableNotFound()}) + + // RENAME TABLE + Safe("RENAME TABLE changes logical name in DBC", {|| TestRenameTableChangesName()}) + Safe("RENAME TABLE does not rename physical file", {|| TestRenameTableFileUnchanged()}) + Safe("RENAME TABLE unknown name returns FALSE", {|| TestRenameTableNotFound()}) + + RETURN _nFail == 0 + END METHOD + + // ----------------------------------------------------------------------- + // ADD TABLE tests + // ----------------------------------------------------------------------- + + PRIVATE STATIC METHOD TestAddTableRegisters() AS LOGIC + LOCAL cDb := DbPath("addreg") AS STRING + LOCAL cTbl := DbPath("addreg_t") AS STRING + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + TRY + TestHelper.OpenActiveDb(cDb) + LOCAL lCreate := TestHelper.CreateFreeTable(cTbl) AS LOGIC + IF !AssertTrue(lCreate, "CreateFreeTable must succeed") ; RETURN FALSE ; ENDIF + LOCAL lAdd := __VFPAddTable(cTbl, "") AS LOGIC + IF !AssertTrue(lAdd, "ADD TABLE must return TRUE") ; RETURN FALSE ; ENDIF + LOCAL oDb := Dbc.GetCurrent() AS DbcDatabase + RETURN AssertTrue(oDb:FindTable("ADDREG_T") != NULL_OBJECT, "Table must appear in DBC after ADD TABLE") + FINALLY + CLOSE DATABASES ALL + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + END TRY + END METHOD + + PRIVATE STATIC METHOD TestAddTableWithLongName() AS LOGIC + LOCAL cDb := DbPath("addname") AS STRING + LOCAL cTbl := DbPath("addname_t") AS STRING + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + TRY + TestHelper.OpenActiveDb(cDb) + LOCAL lCreate := TestHelper.CreateFreeTable(cTbl) AS LOGIC + IF !AssertTrue(lCreate, "CreateFreeTable must succeed") ; RETURN FALSE ; ENDIF + LOCAL lAdd := __VFPAddTable(cTbl, "MyLongTableName") AS LOGIC + IF !AssertTrue(lAdd, "ADD TABLE NAME must return TRUE") ; RETURN FALSE ; ENDIF + LOCAL oDb := Dbc.GetCurrent() AS DbcDatabase + RETURN AssertTrue(oDb:FindTable("MyLongTableName") != NULL_OBJECT, "Long name must be registered in DBC") + FINALLY + CLOSE DATABASES ALL + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + END TRY + END METHOD + + PRIVATE STATIC METHOD TestAddTableRegistersFields() AS LOGIC + LOCAL cDb := DbPath("addfld") AS STRING + LOCAL cTbl := DbPath("addfld_t") AS STRING + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + TRY + TestHelper.OpenActiveDb(cDb) + LOCAL lCreate := TestHelper.CreateFreeTable(cTbl) AS LOGIC // ID (I) + NAME (C) + IF !AssertTrue(lCreate, "CreateFreeTable must succeed") ; RETURN FALSE ; ENDIF + LOCAL lAdd := __VFPAddTable(cTbl, "") AS LOGIC + IF !AssertTrue(lAdd, "ADD TABLE must return TRUE") ; RETURN FALSE ; ENDIF + LOCAL oDb := Dbc.GetCurrent() AS DbcDatabase + LOCAL oTable := oDb:FindTable("ADDFLD_T") AS DbcTable + RETURN AssertTrue(oTable != NULL_OBJECT, "Table must appear in DBC") ; + .AND. AssertEqual(oTable:Fields:Count, 2, "DBC must record 2 fields") + FINALLY + CLOSE DATABASES ALL + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + END TRY + END METHOD + + PRIVATE STATIC METHOD TestAddTableNonExistent() AS LOGIC + LOCAL cDb := DbPath("addnofile") AS STRING + LOCAL cTbl := DbPath("nosuchtable") AS STRING + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + TRY + TestHelper.OpenActiveDb(cDb) + LOCAL lResult := __VFPAddTable(cTbl + ".DBF", "") AS LOGIC + RETURN AssertTrue(!lResult, "ADD TABLE on a non-existent file must return FALSE") + FINALLY + CLOSE DATABASES ALL + TestHelper.CleanupDb(cDb) + END TRY + END METHOD + + PRIVATE STATIC METHOD TestAddTableNoActiveDb() AS LOGIC + LOCAL cTbl := DbPath("addnodb_t") AS STRING + TestHelper.CleanupTable(cTbl) + TRY + // Ensure no database is active + Dbc.Select() + TestHelper.CreateFreeTable(cTbl) + LOCAL lResult := __VFPAddTable(cTbl + ".DBF", "") AS LOGIC + RETURN AssertTrue(!lResult, "ADD TABLE without an active database must return FALSE") + FINALLY + TestHelper.CleanupTable(cTbl) + END TRY + END METHOD + + // ----------------------------------------------------------------------- + // REMOVE TABLE tests + // ----------------------------------------------------------------------- + + PRIVATE STATIC METHOD TestRemoveTableUnregisters() AS LOGIC + LOCAL cDb := DbPath("remreg") AS STRING + LOCAL cTbl := DbPath("remreg_t") AS STRING + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + TRY + TestHelper.OpenActiveDb(cDb) + TestHelper.CreateFreeTable(cTbl) + ADD TABLE (cTbl) + REMOVE TABLE REMREG_T + LOCAL oDb := Dbc.GetCurrent() AS DbcDatabase + RETURN AssertTrue(oDb:FindTable("REMREG_T") == NULL_OBJECT, "Table must be gone from DBC after REMOVE TABLE") + FINALLY + CLOSE DATABASES ALL + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + END TRY + END METHOD + + PRIVATE STATIC METHOD TestRemoveTableKeepsFile() AS LOGIC + LOCAL cDb := DbPath("remkeep") AS STRING + LOCAL cTbl := DbPath("remkeep_t") AS STRING + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + TRY + TestHelper.OpenActiveDb(cDb) + TestHelper.CreateFreeTable(cTbl) + ADD TABLE (cTbl) + REMOVE TABLE REMKEEP_T + RETURN AssertTrue(File(cTbl + ".DBF"), ".DBF file must still exist after REMOVE TABLE without DELETE") + FINALLY + CLOSE DATABASES ALL + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + END TRY + END METHOD + + PRIVATE STATIC METHOD TestRemoveTableDelete() AS LOGIC + LOCAL cDb := DbPath("remdel") AS STRING + LOCAL cTbl := DbPath("remdel_t") AS STRING + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + TRY + TestHelper.OpenActiveDb(cDb) + TestHelper.CreateFreeTable(cTbl) + ADD TABLE (cTbl) + REMOVE TABLE REMDEL_T DELETE + RETURN AssertTrue(!File(cTbl + ".DBF"), ".DBF file must be deleted after REMOVE TABLE DELETE") + FINALLY + CLOSE DATABASES ALL + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + END TRY + END METHOD + + PRIVATE STATIC METHOD TestRemoveTableNotFound() AS LOGIC + LOCAL cDb := DbPath("remnotfound") AS STRING + TestHelper.CleanupDb(cDb) + TRY + TestHelper.OpenActiveDb(cDb) + LOCAL lResult := __VFPRemoveTable("nosuchTable", FALSE, FALSE) AS LOGIC + RETURN AssertTrue(!lResult, "REMOVE TABLE on an unknown table name must return FALSE") + FINALLY + CLOSE DATABASES ALL + TestHelper.CleanupDb(cDb) + END TRY + END METHOD + + // ----------------------------------------------------------------------- + // RENAME TABLE tests + // ----------------------------------------------------------------------- + + PRIVATE STATIC METHOD TestRenameTableChangesName() AS LOGIC + LOCAL cDb := DbPath("renname") AS STRING + LOCAL cTbl := DbPath("renname_t") AS STRING + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + TRY + TestHelper.OpenActiveDb(cDb) + TestHelper.CreateFreeTable(cTbl) + ADD TABLE (cTbl) + RENAME TABLE RENNAME_T TO RenamedTable + LOCAL oDb := Dbc.GetCurrent() AS DbcDatabase + RETURN AssertTrue(oDb:FindTable("RENNAME_T") == NULL_OBJECT, "Old name must not be found after RENAME TABLE") ; + .AND. AssertTrue(oDb:FindTable("RenamedTable") != NULL_OBJECT, "New name must be found after RENAME TABLE") + FINALLY + CLOSE DATABASES ALL + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + END TRY + END METHOD + + PRIVATE STATIC METHOD TestRenameTableFileUnchanged() AS LOGIC + LOCAL cDb := DbPath("renfile") AS STRING + LOCAL cTbl := DbPath("renfile_t") AS STRING + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + TRY + TestHelper.OpenActiveDb(cDb) + TestHelper.CreateFreeTable(cTbl) + ADD TABLE (cTbl) + RENAME TABLE RENFILE_T TO NewLogicalName + RETURN AssertTrue(File(cTbl + ".DBF"), "Physical .DBF must still exist after RENAME TABLE") + FINALLY + CLOSE DATABASES ALL + TestHelper.CleanupDb(cDb) + TestHelper.CleanupTable(cTbl) + END TRY + END METHOD + + PRIVATE STATIC METHOD TestRenameTableNotFound() AS LOGIC + LOCAL cDb := DbPath("rennotfound") AS STRING + TestHelper.CleanupDb(cDb) + TRY + TestHelper.OpenActiveDb(cDb) + LOCAL lResult := __VFPRenameTable("nosuchTable", "newName") AS LOGIC + RETURN AssertTrue(!lResult, "RENAME TABLE on an unknown name must return FALSE") + FINALLY + CLOSE DATABASES ALL + TestHelper.CleanupDb(cDb) + END TRY + END METHOD + + // ----------------------------------------------------------------------- + // Infrastructure + // ----------------------------------------------------------------------- + + PRIVATE STATIC METHOD DbPath(cName AS STRING) AS STRING + RETURN Path.Combine(_cDataPath, cName) + END METHOD + + PRIVATE STATIC METHOD Safe(cName AS STRING, cbTest AS USUAL) AS VOID + LOCAL lOk := FALSE AS LOGIC + TRY + lOk := (LOGIC) Eval(cbTest) + CATCH ex AS Exception + ? " [FAIL] " + cName + ? " EXCEPTION: " + ex:Message + _nFail += 1 + RETURN + END TRY + IF lOk + _nPass += 1 + ? " [PASS] " + cName + ELSE + _nFail += 1 + ? " [FAIL] " + cName + ENDIF + END METHOD + + PRIVATE STATIC METHOD AssertEqual(uActual AS USUAL, uExpected AS USUAL, cMsg AS STRING) AS LOGIC + RETURN TestHelper.AssertEqual(uActual, uExpected, cMsg) + END METHOD + + PRIVATE STATIC METHOD AssertTrue(lCond AS LOGIC, cMsg AS STRING) AS LOGIC + RETURN TestHelper.AssertTrue(lCond, cMsg) + END METHOD + +END CLASS diff --git a/src/Tests/DbcTest/TestSuite_Experimental.prg b/src/Tests/DbcTest/TestSuite_Experimental.prg new file mode 100644 index 0000000000..ab23883678 --- /dev/null +++ b/src/Tests/DbcTest/TestSuite_Experimental.prg @@ -0,0 +1,87 @@ +// +// TestSuite_Experimental.prg +// +// Sandbox for work-in-progress tests. +// +// PURPOSE +// ------- +// Write exploratory or diagnostic tests here during design and debugging. +// Once a test is proven and stable it should be promoted to the appropriate +// permanent TestSuite_*.prg file. +// +// The call to this suite is commented out in TestRunner.prg so it never +// contributes to the official pass/fail total. Uncomment that call while +// you are actively working on an experiment; re-comment it before committing. +// +// Current experiments +// ------------------- +// (none — sandbox is empty; add new experiments here) +// + +USING System +USING System.Collections.Generic + +STATIC CLASS TestSuite_Experimental + + PRIVATE STATIC _nPass AS INT + PRIVATE STATIC _nFail AS INT + + PUBLIC STATIC PROPERTY PassCount AS INT + GET + RETURN _nPass + END GET + END PROPERTY + + PUBLIC STATIC PROPERTY FailCount AS INT + GET + RETURN _nFail + END GET + END PROPERTY + + PUBLIC STATIC METHOD RunAll(cDataPath AS STRING) AS LOGIC + _nPass := 0 + _nFail := 0 + + SET(Set.Default, cDataPath) + + ? + ? " --- Experimental (work-in-progress) ---" + + // Add new experiment calls here, e.g.: + // TestSuite_Experimental.Safe("My experiment", {|| TestSuite_Experimental.TestMyExperiment()}) + + RETURN _nFail == 0 + END METHOD + + // ----------------------------------------------------------------------- + // Infrastructure + // ----------------------------------------------------------------------- + + PRIVATE STATIC METHOD Safe(cName AS STRING, cbTest AS USUAL) AS VOID + LOCAL lOk := FALSE AS LOGIC + TRY + lOk := (LOGIC) Eval(cbTest) + CATCH ex AS Exception + ? " [FAIL] " + cName + ? " EXCEPTION: " + ex:Message + _nFail += 1 + RETURN + END TRY + IF lOk + _nPass += 1 + ? " [PASS] " + cName + ELSE + _nFail += 1 + ? " [FAIL] " + cName + ENDIF + END METHOD + + PRIVATE STATIC METHOD AssertEqual(uActual AS USUAL, uExpected AS USUAL, cMsg AS STRING) AS LOGIC + RETURN TestHelper.AssertEqual(uActual, uExpected, cMsg) + END METHOD + + PRIVATE STATIC METHOD AssertTrue(lCond AS LOGIC, cMsg AS STRING) AS LOGIC + RETURN TestHelper.AssertTrue(lCond, cMsg) + END METHOD + +END CLASS diff --git a/src/Tests/DbcTest/TestSuite_Misc.prg b/src/Tests/DbcTest/TestSuite_Misc.prg new file mode 100644 index 0000000000..e415c7306a --- /dev/null +++ b/src/Tests/DbcTest/TestSuite_Misc.prg @@ -0,0 +1,110 @@ +// +// TestSuite_Misc.prg +// +// Miscellaneous smoke tests originally in Program.prg. +// These verify that date/string functions accept USUAL and PRIVATE variables +// without throwing exceptions. +// + +USING System + +STATIC CLASS TestSuite_Misc + + PRIVATE STATIC _nPass AS INT + PRIVATE STATIC _nFail AS INT + + PUBLIC STATIC PROPERTY PassCount AS INT + GET + RETURN _nPass + END GET + END PROPERTY + + PUBLIC STATIC PROPERTY FailCount AS INT + GET + RETURN _nFail + END GET + END PROPERTY + + PUBLIC STATIC METHOD RunAll(cDataPath AS STRING) AS LOGIC + _nPass := 0 + _nFail := 0 + + ? + ? " --- TestSuite_Misc ---" + + Safe("Date functions on USUAL variable", {|| TestDateFunctionsUsual()}) + Safe("Date functions on PRIVATE variable", {|| TestDateFunctionsPrivate()}) + Safe("Quarter with string USUAL", {|| TestQuarterWithString()}) + + RETURN _nFail == 0 + END METHOD + + // ----------------------------------------------------------------------- + // Tests + // ----------------------------------------------------------------------- + + PRIVATE STATIC METHOD TestDateFunctionsUsual() AS LOGIC + LOCAL u AS USUAL + u := Today() + ? GoMonth(u, 1) + ? Quarter(u, 1) + ? Week(u, 1) + ? Week(u, 2) + ? Week(u, 3) + ? Dmy(u) + ? Mdy(u) + RETURN TRUE + END METHOD + + PRIVATE STATIC METHOD TestDateFunctionsPrivate() AS LOGIC + PRIVATE p + p := Today() + ? GoMonth(p, 1) + ? Quarter(p, 1) + ? Week(p, 1) + ? Week(p, 2) + ? Week(p, 3) + ? Dmy(p) + ? Mdy(p) + RETURN TRUE + END METHOD + + PRIVATE STATIC METHOD TestQuarterWithString() AS LOGIC + LOCAL u AS USUAL + u := "abc" + ? Quarter(u, 1) + RETURN TRUE + END METHOD + + // ----------------------------------------------------------------------- + // Infrastructure + // ----------------------------------------------------------------------- + + PRIVATE STATIC METHOD Safe(cName AS STRING, cbTest AS USUAL) AS VOID + LOCAL lOk := FALSE AS LOGIC + TRY + lOk := (LOGIC) Eval(cbTest) + CATCH ex AS Exception + ? " [FAIL] " + cName + ? " EXCEPTION: " + ex:Message + _nFail += 1 + RETURN + END TRY + IF lOk + _nPass += 1 + ? " [PASS] " + cName + ELSE + _nFail += 1 + ? " [FAIL] " + cName + ENDIF + END METHOD + + PRIVATE STATIC METHOD AssertEqual(uActual AS USUAL, uExpected AS USUAL, cMsg AS STRING) AS LOGIC + RETURN TestHelper.AssertEqual(uActual, uExpected, cMsg) + END METHOD + + PRIVATE STATIC METHOD AssertTrue(lCond AS LOGIC, cMsg AS STRING) AS LOGIC + RETURN TestHelper.AssertTrue(lCond, cMsg) + END METHOD + +END CLASS From 9ae9b8b8be65016d05fa1b653a973ff01332395b Mon Sep 17 00:00:00 2001 From: Fabrice Foray Date: Thu, 28 May 2026 16:33:44 +0200 Subject: [PATCH 09/11] [VFP] Fix SUM and AVERAGE UDCs clause must appear before TO --- src/Common/dbcmd.xh | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/src/Common/dbcmd.xh b/src/Common/dbcmd.xh index ed52a00f96..472c226fc3 100644 --- a/src/Common/dbcmd.xh +++ b/src/Common/dbcmd.xh @@ -432,29 +432,31 @@ <{lfor}>, <{lwhile}>, , , <.rest.>, <.noopt.>; ) -#command SUM [, ] TO [, ] ; +#command SUM [, ] ; [FOR ] ; [WHILE ] ; [NEXT ] ; [RECORD ] ; - [] ; + [] ; [] ; - [ALL] ; + [all] ; + TO [, ] ; ; - => := [ := ] 0 ; + => := [ := ] 0 ; ; DbEval( ; - {|| += [, += ]}, ; + {|| += [, += ]}, ; <{lfor}>, <{lwhile}>, , , <.rest.>, <.noopt.>; ) -#command AVERAGE [ [, ] TO [, ]] ; +#command AVERAGE [ [, ] ; [FOR ] ; [WHILE ] ; [NEXT ] ; [RECORD ] ; [] ; [] ; - [ALL] ; + [all] ; + TO [, ]] ; ; => M->__Avg := := [ := ] 0 ; ; From d38811c5abdadb581e54ab10c0995ed671ed3648 Mon Sep 17 00:00:00 2001 From: Fabrice Foray Date: Thu, 28 May 2026 18:05:40 +0200 Subject: [PATCH 10/11] [VFP] Add support for COPY MEMO command --- src/Common/dbcmd.xh | 3 ++ src/Runtime/XSharp.RT/RDD/DbBulk.prg | 35 +++++++++++++++++++++- src/Runtime/XSharp.VFP/SQL/EmbeddedSql.prg | 2 +- 3 files changed, 38 insertions(+), 2 deletions(-) diff --git a/src/Common/dbcmd.xh b/src/Common/dbcmd.xh index 472c226fc3..d815551eb3 100644 --- a/src/Common/dbcmd.xh +++ b/src/Common/dbcmd.xh @@ -489,6 +489,9 @@ #command SET MEMOBLOCKSIZE TO => RDDInfo(_SET_MEMOBLOCKSIZE, 512) #command SET OPTIMIZE => RDDInfo(_SET_OPTIMIZE, <(x)>) +#command COPY MEMO TO <(file)> [AS ] ; + => DbCopyMemo( <"field">, <(file)>, [, ] ) + #endif // DBCMD_XH diff --git a/src/Runtime/XSharp.RT/RDD/DbBulk.prg b/src/Runtime/XSharp.RT/RDD/DbBulk.prg index 842c5d7141..f289cc231f 100644 --- a/src/Runtime/XSharp.RT/RDD/DbBulk.prg +++ b/src/Runtime/XSharp.RT/RDD/DbBulk.prg @@ -988,4 +988,37 @@ FUNCTION DbUpdate(cAlias, cbKey, lRand, cbReplace) AS LOGIC CLIPPER RETURN (lRetCode) - + /// + /// Runtime implementation of VFP COPY MEMO FieldName TO FileName [ADDITIVE] [AS nCodePage]. + /// Copies the contents of the specified memo field in the current record to a text file. + /// + FUNCTION DbCopyMemo(cField AS STRING, cFile AS STRING, lAdditive AS LOGIC, nCodePage AS LONG) AS LOGIC + LOCAL nPos := FieldPos(cField) AS DWORD + IF nPos == 0 + RETURN FALSE + ENDIF + LOCAL uContent := FieldGet(nPos) AS USUAL + IF !IsString(uContent) + RETURN FALSE + ENDIF + LOCAL cContent := (STRING) uContent AS STRING + LOCAL oEnc AS System.Text.Encoding + IF nCodePage == 0 + oEnc := RuntimeState.WinEncoding + ELSE + TRY + oEnc := System.Text.Encoding.GetEncoding(nCodePage) + CATCH + oEnc := RuntimeState.WinEncoding + END TRY + ENDIF + TRY + BEGIN USING VAR oWriter := System.IO.StreamWriter{ cFile, lAdditive, oEnc } + oWriter:Write(cContent) + END USING + CATCH e AS Exception + RuntimeState.LastRddError := e + RETURN FALSE + END TRY + RETURN TRUE +END FUNCTION diff --git a/src/Runtime/XSharp.VFP/SQL/EmbeddedSql.prg b/src/Runtime/XSharp.VFP/SQL/EmbeddedSql.prg index 5d1fa7468c..864615ccd5 100644 --- a/src/Runtime/XSharp.VFP/SQL/EmbeddedSql.prg +++ b/src/Runtime/XSharp.VFP/SQL/EmbeddedSql.prg @@ -173,7 +173,7 @@ STATIC CLASS FoxEmbeddedSQL // Use the resolved absolute path and shared mode so the open succeeds // even when an exclusively-locked DBC is active in DbcDataSession. - LOCAL lDbOpen := DbUseArea(TRUE, "DBFVFP", cFullPath, cAlias, TRUE, FALSE) AS LOGIC + DbUseArea(TRUE, "DBFVFP", cFullPath, cAlias, TRUE, FALSE) FOR var nI := 1 to oTable:Columns:Count var oCol := oTable:Columns[nI-1] DbFieldInfo(DBS_CAPTION, nI, oCol:Caption) From 7b4e31318192766a808f97abd27b19b929bb3344 Mon Sep 17 00:00:00 2001 From: Fabrice Foray Date: Thu, 28 May 2026 18:23:44 +0200 Subject: [PATCH 11/11] [VFP] Add support of REPLACE ... ADDITIVE command --- src/Common/dbcmd.xh | 25 ++++++++++++++++++++++++ src/Runtime/XSharp.RT/RDD/Db.prg | 33 ++++++++++++++++++++++++++++++++ 2 files changed, 58 insertions(+) diff --git a/src/Common/dbcmd.xh b/src/Common/dbcmd.xh index d815551eb3..82eeea862b 100644 --- a/src/Common/dbcmd.xh +++ b/src/Common/dbcmd.xh @@ -492,6 +492,31 @@ #command COPY MEMO TO <(file)> [AS ] ; => DbCopyMemo( <"field">, <(file)>, [, ] ) +// REPLACE ... [ADDITIVE] — without IN clause +#command REPLACE <(f1)> WITH [] ; + [, <(fn)> WITH []] ; + [FOR ] [WHILE ] [NEXT ] [RECORD ] ; + [] [] [all] ; + => DbEval( ; + {|| DbAutoLock(), ; + __FieldSetAdd(<(f1)>, , <.add1.>) ; + [, __FieldSetAdd(<(fn)>, , <.addn.>)], ; + DbAutoUnLock() }, ; + <{lfor}>, <{lwhile}>, , , <.rest.>, <.noopt.> ; + ) + +// REPLACE ... [ADDITIVE] IN workarea — defined LAST, tried FIRST +#command REPLACE <(f1)> WITH [] ; + [, <(fn)> WITH []] ; + [FOR ] [WHILE ] [NEXT ] [RECORD ] ; + [] IN <(wa)> [] [all] ; + => __VfpReplaceIn( <(wa)>, ; + {|| DbAutoLock(), ; + __FieldSetAdd(<(f1)>, , <.add1.>) ; + [, __FieldSetAdd(<(fn)>, , <.addn.>)], ; + DbAutoUnLock() }, ; + <{lfor}>, <{lwhile}>, , , <.rest.>, <.noopt.> ; + ) #endif // DBCMD_XH diff --git a/src/Runtime/XSharp.RT/RDD/Db.prg b/src/Runtime/XSharp.RT/RDD/Db.prg index 1464c3192c..03882c2465 100644 --- a/src/Runtime/XSharp.RT/RDD/Db.prg +++ b/src/Runtime/XSharp.RT/RDD/Db.prg @@ -1255,3 +1255,36 @@ FUNCTION DbAutoLockArea(area AS STRING) AS USUAL STRICT FUNCTION DbAutoUnLockArea(area AS STRING) AS USUAL STRICT (area)->(DbAutoUnLock()) RETURN NIL + +// REPLACE ... IN: switch to the target work area, evaluate, restore. +FUNCTION __VfpReplaceIn(uArea AS USUAL, cbAction AS USUAL, cbFor AS USUAL, ; + cbWhile AS USUAL, nNext AS USUAL, nRec AS USUAL, ; + lRest AS LOGIC, lNoOpt AS LOGIC) AS LOGIC + LOCAL nOld := VoDbGetSelect() AS DWORD + IF IsString(uArea) + DbSelectArea((STRING) uArea) + ELSEIF IsNumeric(uArea) + DbSelectArea((DWORD)(LONG) uArea) + ENDIF + LOCAL lOk := DbEval(cbAction, cbFor, cbWhile, nNext, nRec, lRest, lNoOpt) AS LOGIC + DbSelectArea(nOld) + RETURN lOk + +// REPLACE ... ADDITIVE: for memo fields, append instead of overwrite. +FUNCTION __FieldSetAdd(cField AS STRING, uValue AS USUAL, lAdditive AS LOGIC) AS USUAL + LOCAL nPos := FieldPos(cField) AS DWORD + IF nPos == 0 + RETURN NIL + ENDIF + IF lAdditive + // ADDITIVE is meaningful only for memo fields (type 'M'). + // For any other field type the flag is silently ignored per VFP spec. + LOCAL cType := (STRING) DbFieldInfo(DBS_TYPE, nPos) AS STRING + IF cType == "M" + LOCAL uCurrent := FieldGet(nPos) AS USUAL + IF IsString(uCurrent) .AND. IsString(uValue) + RETURN FieldPut(nPos, (STRING) uCurrent + (STRING) uValue) + ENDIF + ENDIF + ENDIF + RETURN __FieldSet(cField, uValue)