fcode.class

Gambas is a graphical development environment based on a Basic interpreter, like Visual Basic. It us

' Gambas class file

STATIC PRIVATE $cType AS Collection

PUBLIC Server AS CServer
PUBLIC Database AS String

PRIVATE $sKey AS String

STATIC PUBLIC SUB _init()

  $cType = NEW Collection
  $cType[gb.Boolean] = "Boolean"
  $cType[gb.Integer] = "Integer"
  $cType[gb.Float] = "Float"
  $cType[gb.Date] = "Date"
  $cType[gb.String] = "String"

END


PUBLIC SUB Form_Open()

  DIM sProject AS String

  sProject = File.Name(FMain.Project)

  lblProject.Text = "<b>" & sProject & "</b><br>" & File.Dir(FMain.Project)
  lblServer.Text = Server.Name
  lblDatabase.Text = Database
  imgIcon.Picture = FMain.GetProjectIcon(FMain.Project, 48)

  $sKey = Replace("/Code" &/ sProject &/ Server.Key &/ Database, " ", "_")

  'txtModule.Text = FMain.Config.ReadString($sKey &/ "Module", "MDatabase")
  'txtProcedure.Text = FMain.Config.ReadString($sKey &/ "Procedure", "CreateDatabase")
  'chkUpdate.Value = FMain.Config.ReadString($sKey &/ "AutoUpdate", FALSE)
  txtModule.Text = Settings[$sKey &/ "Module", "MDatabase"]
  txtProcedure.Text = Settings[$sKey &/ "Procedure", "CreateDatabase"]
  chkUpdate.Value = Settings[$sKey &/ "AutoUpdate", FALSE]

END

PRIVATE FUNCTION WriteConfig(bCheck AS Boolean) AS Boolean

  DIM sModule AS String
  DIM sProc AS String

  sModule = Trim(txtModule.Text)
  IF NOT sModule THEN
    IF bCheck THEN
      Message.Warning(("Please enter a module name."))
      txtModule.SetFocus
      RETURN TRUE
    ENDIF
  ELSE
    'FMain.Config.WriteString($sKey &/ "Module", sModule)
    Settings[$sKey &/ "Module"] = sModule
  ENDIF

  sProc = Trim(txtProcedure.Text)
  IF NOT sProc THEN
    IF bCheck THEN
      Message.Warning(("Please enter a procedure name."))
      txtProcedure.SetFocus
      RETURN TRUE
    ENDIF
  ELSE
    'FMain.Config.WriteString($sKey &/ "Procedure", sProc)
    Settings[$sKey &/ "Procedure"] = sProc
  ENDIF

  'FMain.Config.WriteString($sKey &/ "AutoUpdate", chkUpdate.Value)
  Settings[$sKey &/ "AutoUpdate"] = chkUpdate.Value

END


PUBLIC SUB btnGenerate_Click()

  IF WriteConfig(TRUE) THEN RETURN
  IF GenerateCode(Server, Database) THEN RETURN
  ME.Close(TRUE)

END


STATIC PUBLIC FUNCTION GenerateCode(hServer AS CServer, sDatabase AS String) AS Boolean

  DIM sKey AS String
  DIM sPath AS String
  DIM sModule AS String
  DIM sProc AS String
  DIM sTemp AS String
  DIM hFile AS File
  DIM hTemp AS File
  DIM bWaitEnd AS Boolean
  DIM sLine AS String
  DIM bDone AS Boolean

  sKey = "/Code" &/ FMain.Project &/ hServer.Key &/ sDatabase
  'sModule = FMain.Config.ReadString(sKey &/ "Module", "MDatabase")
  sModule = Settings[sKey &/ "Module", "MDatabase"]
  'sProc = FMain.Config.ReadString(sKey &/ "Procedure", "CreateDatabase")
  sProc = Settings[sKey &/ "Procedure", "CreateDatabase"]

  sPath = FMain.Project &/ sModule & ".module"
  sTemp = Temp$()

  OPEN sTemp FOR CREATE AS #hTemp

  bDone = FALSE
  IF Exist(sPath) THEN
    OPEN sPath FOR READ AS #hFile
    WHILE NOT Eof(hFile)
      LINE INPUT #hFile, sLine
      IF bWaitEnd THEN
        IF UCase(Trim(sLine)) = "END" THEN
          bWaitEnd = FALSE
        ENDIF
        CONTINUE
      ENDIF
      IF sLine LIKE ("PROCEDURE " & sProc & "(*") THEN
        bWaitEnd = TRUE
        DumpCode(hTemp, sProc, hServer, sDatabase)
        bDone = TRUE
        CONTINUE
      ENDIF
      PRINT #hTemp, sLine
    WEND
    CLOSE #hFile
  ELSE
    PRINT #hTemp,"' Gambas module file\n"
  ENDIF

  IF NOT bDone THEN DumpCode(hTemp, sProc, hServer, sDatabase)

  CLOSE #hTemp

  TRY KILL sPath
  COPY sTemp TO sPath
  TRY KILL sTemp

CATCH

  Message.Error(("Cannot generate Gambas code.") & "\n" & Subst(("Server: &1"), hServer.Name) & "\n" & Subst(("Database: &1"), sDatabase) & "\n\n" & Error.Text)
  RETURN TRUE

END


STATIC PRIVATE SUB DumpCode(hFile AS File, sProc AS String, hServer AS CServer, sDatabase AS String)

  DIM hConn AS CConnection
  DIM sType AS String
  DIM hTable AS Table
  DIM hField AS Field
  DIM hIndex AS Index
  DIM sField AS String
  DIM bIndex AS Boolean
  DIM bFirst AS Boolean

  hConn = NEW CConnection(hServer, sDatabase, TRUE)
  hConn.Open

  PRINT #hFile, "PROCEDURE " & sProc & "(hConn AS Connection, sDatabase AS String)\n"
  PRINT #hFile, "  ' Generated by the Gambas database manager - "; Now; "\n"
  PRINT #hFile, "  DIM hTable AS Table\n"

  FOR EACH hTable IN hConn.Handle.Tables

    IF hTable.System THEN CONTINUE

    WITH hTable

      PRINT #hFile, "  hTable = hConn.Tables.Add(\"" & .Name & "\"";
      IF .Type THEN PRINT #hFile, ", \"" & .Type & "\"";
      PRINT #hFile, ")\n"

      PRINT #hFile, "  WITH hTable\n"

      FOR EACH hField IN hTable.Fields
        WITH hField
          PRINT #hFile, "    .Fields.Add(\"" & .Name & "\", gb." & $cType[.Type];
          IF .Type = gb.String THEN
            PRINT #hFile, ", " & .Length;
            IF .Default THEN
              PRINT #hFile, ", \"" & .Default & "\"";
            ENDIF
          ELSE IF NOT IsNull(.Default) THEN
            PRINT #hFile, ", , ";
            IF .Type = gb.Date THEN
              PRINT #hFile, "CDate(\"" & CStr(.Default) & "\")";
            ELSE IF .Type = gb.Boolean THEN
              PRINT #hFile, If(.Default, "TRUE", "FALSE");
            ELSE
              PRINT #hFile, CStr(.Default);
            ENDIF
          ENDIF
          PRINT #hFile, ")"
        END WITH
      NEXT

      PRINT #hFile, "\n    .PrimaryKey = [ ";
      bFirst = FALSE
      FOR EACH sField IN .PrimaryKey
        IF bFirst THEN PRINT #hFile, ", ";
        PRINT #hFile, "\"" & sField & "\"";
        bFirst = TRUE
      NEXT
      PRINT #hFile, " ]\n"

      bIndex = FALSE
      FOR EACH hIndex IN hTable.Indexes
        WITH hIndex
          IF .Primary THEN CONTINUE
          PRINT #hFile, "    .Indexes.Add(\"" & .Name & "\", \"" & .Fields & "\"";
          IF .Unique THEN PRINT #hFile, ", TRUE";
          PRINT #hFile, ")"
          bIndex = TRUE
        END WITH
      NEXT

      IF bIndex THEN PRINT #hFile

    END WITH

    PRINT #hFile, "    .Update\n"
    PRINT #hFile, "  END WITH\n"

  NEXT

  PRINT #hFile, "END\n"

END

PUBLIC SUB btnClose_Click()

  IF chkUpdate.Value THEN
    WriteConfig(FALSE)
  ENDIF
  ME.Close

END