Health Organizer Code

{

    Health Organizer (http://sourceforge.net/projects/hor/,
                      http://hor.sourceforge.net/)
    Copyright (C) 2014  Andrea Urbani ( matfanjol@users.sf.net,
	                                matfanjol@mail.com )

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.

}
unit hor_main;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, pqconnection, sqldb, FileUtil, Forms,
  Controls, Graphics, Dialogs, defaulttranslator, ComCtrls, Menus, ActnList, sqlscript;

type

  { TfrmMain }

  TfrmMain = class(TForm)
    actDbConnect: TAction;
    actHeAbout: TAction;
    actQuit: TAction;
    MainActionList: TActionList;
    MainMenu: TMainMenu;
    MenuItem1: TMenuItem;
    miHeAbout: TMenuItem;
    miHelp: TMenuItem;
    miLaItaliano: TMenuItem;
    miLaEnglish: TMenuItem;
    miLanguage: TMenuItem;
    miDbQuit: TMenuItem;
    miDbOpen: TMenuItem;
    miDatabase: TMenuItem;
    pgConnection: TPQConnection;
    pgQuery: TSQLQuery;
    pgTransaction: TSQLTransaction;
    pgScript: TSQLScript;
    StatusBar: TStatusBar;
    procedure actDbConnectExecute(Sender: TObject);
    procedure actHeAboutExecute(Sender: TObject);
    procedure actQuitExecute(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure miLaEnglishClick(Sender: TObject);
    procedure pgScriptException(Sender: TObject; Statement: TStrings;
      TheException: Exception; var Continue: boolean);
  protected
    procedure SelectLanguage( MenuItem : TMenuItem );
    procedure BuildTitle;
    function DB_Update(): boolean;
  private
    { private declarations }
  public
    var ReadOnlyMode: boolean;
    function DB_Connect( const Server, Port, UserName, Password, Database :
          string): boolean;
  end;

var
  frmMain: TfrmMain;
  Traduzioni: string;

const
  constMyLatestKnownDbVersion=1;

implementation

{$R *.lfm}

{ TfrmMain }

Uses hor_dbopen, hor_about, hor_messages;

procedure TfrmMain.actQuitExecute(Sender: TObject);
begin
  Application.Terminate;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  ReadOnlyMode := false;
  BuildTitle;
end;

procedure TfrmMain.actDbConnectExecute(Sender: TObject);
begin
  Application.CreateForm(TfrmDbConnect,frmDbConnect);
  if ( frmDbConnect.ShowModal = mrOK ) then
//    DatabaseChanged
  frmDbConnect.Release;
end;

procedure TfrmMain.actHeAboutExecute(Sender: TObject);
begin
  Application.CreateForm(TfrmAbout, frmAbout);
  frmAbout.ShowModal;
  frmAbout.Release;
end;

procedure TfrmMain.miLaEnglishClick(Sender: TObject);
begin
  if ( Sender is TMenuItem ) then
    SelectLanguage( Sender as TMenuItem );
end;

procedure TfrmMain.pgScriptException(Sender: TObject; Statement: TStrings;
  TheException: Exception; var Continue: boolean);
begin
  Continue := false;
  raise Exception.Create( Statement.Text + LineEnding + TheException.Message );
end;

procedure TfrmMain.SelectLanguage(MenuItem: TMenuItem);
var
  I : integer;
begin
  I := miLanguage.Count-1;
  while ( I >= 0 ) do
  begin
    if ( miLanguage.Items[I] = MenuItem ) then
    begin
      miLanguage.Items[I].Checked:=true;
      if ( miLanguage.Items[I] = miLaItaliano ) then
        SetDefaultLang('it')
      else
        // The default in the case of not already handled language
        SetDefaultLang('en');
      BuildTitle;
    end
    else
      miLanguage.Items[I].Checked:=false;
    Dec(I);
  end;
end;

procedure TfrmMain.BuildTitle;
begin
  Caption := rsAboutTitle + ' - ' + rsAboutBrief;
end;

function TfrmMain.DB_Update: boolean;
var
  DbVersion : integer;
  ScriptPath, ScriptFile : string;
begin
  result := false;
  // I start checking which is the starting database version
  DbVersion := 0;
  with pgQuery do
  begin
    if Active then
      Close;
    SQL.Clear;
    SQL.Add('Select "DbVersion" from "tSettings" where "ID"=1;');
    try
      Open;
      DbVersion := Fields[0].AsInteger;
      Close;
    except
      // Ok anyway: it means there are no tables ==> DbVersion = 0 ==> already
      // set at the begin of the this function
    end;
  end;
  if ( DbVersion > constMyLatestKnownDbVersion ) then
    if ( MessageDlg( rsMsgUnknownDatabaseVersion, Format(
      rsMsgDatabaseVersionHigherThanMine, [ DbVersion,
        constMyLatestKnownDbVersion ] ) + LineEnding +
          rsMsgDatabaseUsedWithAnewerVersion + LineEnding + LineEnding +
            rsMsgUseItInReadOnlyMode, mtWarning,
              [mbYes,mbNo], 0, mbNo ) = mrYes ) then
      ReadOnlyMode := true
    else
    begin
      Application.Terminate;
      exit;
    end;
  // I load and run all the scripts to reach the final version
  // Each script will automatically start and commit a new transaction, so no
  // pending transaction has to exist.
  if ( pgTransaction.Active ) then
    pgTransaction.Commit;
  ScriptFile := '';
  try
    ScriptPath := ExtractFilePath(ParamStr(0)) + 'scripts' + DirectorySeparator;
    Inc( DbVersion );
    while ( DbVersion <= constMyLatestKnownDbVersion ) do
    begin
      ScriptFile := ScriptPath + format( 'ver%.4d.sql', [ DbVersion ] );
      if ( not FileExists( ScriptFile ) ) then
      begin
        MessageDlg( rsMsgError, format( rsMsgFileDoesntExist, [ ScriptFile ] ) +
          LineEnding + rsMsgTipTryToReinstall, mtError, [ mbOk ], 0 );
        Application.Terminate;
        exit;
      end;

      // I load and run the script
      pgScript.Script.LoadFromFile( ScriptFile );
      pgScript.ExecuteScript;

      Inc( DbVersion );
    end;
    // The transaction should never be active, but I check it anyway...
    if ( pgTransaction.Active ) then
      pgTransaction.Commit;
    result := true;
  except
    on E: Exception do
    begin
      MessageDlg( rsMsgError, ScriptFile + LineEnding + E.Message, mtError, [
        mbOk ], 0 );
      if ( pgTransaction.Active ) then
        pgTransaction.Rollback;
    end;
  end;
end;

function TfrmMain.DB_Connect(const Server, Port, UserName, Password, Database:
    string): boolean;
begin
  result := false;
  if pgConnection.Connected then
    pgConnection.Connected := false;
  pgConnection.HostName:=Server;
  pgConnection.Params.Clear;
  pgConnection.Params.Add('port=' + Port);
  pgConnection.UserName:=UserName;
  pgConnection.Password:=Password;
  pgConnection.DatabaseName:=Database;
  try
    Screen.Cursor:=crSQLWait;
    try
      pgConnection.Connected:=true;
      result := DB_Update();
      StatusBar.Panels[0].Text:=Format(rsMsgConnectionDetails, [Server, Port,
        Database, UserName] );
    finally
      Screen.Cursor:=crDefault;
    end;
  except
    on E: Exception do
    begin
      MessageDlg( rsMsgError, E.Message, mtError, [ MbOK ], 0 );
      StatusBar.Panels[0].Text:='';
      result := false;
    end;
  end;
end;

end.