unit Msgu;
{ Intended for platform independent message/progress boxes. Originally
  written for DOS - TurboVision. }
{
  (C) 2000 - 2002 Jindrich Jindrich, Pavel Pisa, PiKRON Ltd.

  Originators of the CHROMuLAN project:

  Jindrich Jindrich - http://www.jindrich.com
                      http://orgchem.natur.cuni.cz/Chromulan/
                      software developer, project coordinator
  Pavel Pisa        - http://cmp.felk.cvut.cz/~pisa
                      embeded software developer
  PiKRON Ltd.       - http://www.pikron.com
                      project initiator, sponsor, instrument developer

  The CHROMuLAN project is distributed under the GNU General Public Licence.
  See file COPYING for details.

  Originators reserve the right to use and publish sources
  under different conditions too. If third party contributors
  do not accept this condition, they can delete this statement
  and only GNU license will apply.
}

{$I DEFINE.PAS}
interface
uses
  SysUtils, Dialogs, Controls, Classes,
  UtlType, WinUtl, Language;

type
  TProgressBox = pointer;
  TProgressBoxResult = longint;
  TProgressBoxAction = Int16;
  TProgressBoxFn = function(var AProgressBox:TProgressBox; what:TProgressBoxAction; const Msg:string;
    X,Y:longint):TProgressBoxResult;

  TSysErrorProc = procedure(msg:string);
  TSysOutputProc = procedure(msg:string);

const
  DefaultProgressBox:pointer = pointer(1);

{for ShowMessage box:}
{smXXXX}
{what kind of message:}
const
  smWarning      = $0000;       { Display a Warning box }
    smWarn       = smWarning;
  smError        = $0001;       { Display a Error box (adds there OK button)}
  smInformation  = $0002;       { Display an Information Box }
    smInfo       = smInformation;
  smConfirmation = $0003;       { Display a Confirmation Box }
    smConfirm    = smConfirmation;

  {specialized messages:}
  smOutOfMemory  = $0008;
    smOOM        = smOutOfMemory;
  smFileNotFound = $0009;
  smFileExistsOverwrite = $000A;
  smFileModifiedSave = $000B;

{what buttons to insert to message box}
  smYes          = $0100;       { Put a Yes button into the dialog }
  smNo           = $0200;       { Put a No button into the dialog }
  smOK           = $0400;       { Put an OK button into the dialog }
  smCancel       = $0800;       { Put a Cancel button into the dialog }

  smDefaultNo    = $1000;       { make No button default (in yes/no boxes)}
  smDefaultCancel = $2000;      { make Cancel button default (in OK/Cancel boxes)}

  smYesNo        = smYes + smNo;
  smNoYes        = smYes + smNo + smDefaultNo;
  smYesNoCancel  = smYes + smNo + smCancel;{ Standard Yes, No, Cancel dialog }
  smOKCancel     = smOK + smCancel;        { Standard OK, Cancel dialog }

{/smXXXX}
{v0.24 moved from mytype}
{cmXXXX}
  cmOK      = 10;
  cmCancel  = 11;
  cmYes     = 12;
  cmNo      = 13;
  cmDefault = 14;
{/cmXXXX}
{/v0.24}


function ProgressBox(var AProgressBox:TProgressBox; what:TProgressBoxAction;
  const Msg:string; X,Y:longint):TProgressBoxResult;
{$IFDEF PMODE}export;{$ENDIF}

function ShowMessage(msg:string; options:TShowMessageOptions;
  hc:THelpCtx):TShowMessageResult;
{$IFDEF PMODE}export;{$ENDIF}

procedure SysError(msg:string);
{$IFDEF PMODE}export;{$ENDIF}

procedure SysOutput(msg:string);
{$IFDEF PMODE}export;{$ENDIF}

procedure SetMsgProc(AMsgProcType:TMsgProcType; AProc:pointer);
{$IFDEF PMODE}export;{$ENDIF}

{ Checks if the specified file exists, if yes, then if will ask user
  if it can be overwritten. Returns true if the file does not exists
  or the user answers true. }
function FileExistsOverwrite(const AFileName: string): boolean;

implementation
const
  ShowMessageFn:TShowMessageFn = nil;
  ProgressBoxFn:TProgressBoxFn = nil;
  SysErrorProc:TSysErrorProc = nil;
  SysOutputProc:TSysOutputProc = nil;

function ShowMessage(msg:string; Options:TShowMessageOptions; hc:THelpCtx):TShowMessageResult;
var
  b:byte;
  w:word;
{  ch:char;
  i:integer;}
  {v0.62}
  {type
    TBtnRng = 0..11;
  var
  mb: set of TBtnRng;TMsgDlgBtn}
  mbs: TMsgDlgButtons;
  {/v0.62}
  {v0.75}
  mt: TMsgDlgType;
  {/v0.75}
begin
  if Assigned(ShowMessageFn) then
    ShowMessage := ShowMessageFn(msg, options, hc)
  else begin
    w := Options and $FF00;
    b := Options and $FF;{mytype}
    {v0.75}
    mt := mtConfirmation;
    {/v0.75}
    case b of

      smOutOfMemory: begin
        msg:= 'Not enough memory';
        mt := mtError;
      end;

      {v0.75}
      smError: begin
        w := w or smOK;
        mt := mtError;
      end;

      smInfo: begin
        w := w or smOK;
        mt := mtInformation;
      end;
      {/v0.75
      smError, smInfo : begin
        w := w or smOK;
      end;
      }

      smFileExistsOverWrite: begin
        msg := 'File exist, overwrite?' + msg;
        w := w or smYesNo;
      end;

      smFileNotFound: begin
        msg := 'File not found ' + msg;
        w := w or smOK;
      end;
      {v0.62}
      smFileModifiedSave: begin
        msg := 'File modified, save changes? ' + msg;
        w := w or smYesNoCancel;
      end;
      {/v0.62}

    end;
    {v0.62}
    mbs := [];
    if (w and smYes) <> 0 then
      mbs := mbs + [mbYes];
    if (w and smNo) <> 0 then
      mbs := mbs + [mbNo];
    if (w and smCancel) <> 0 then
      mbs := mbs + [mbCancel];
    {v0.75}
    if (w and smOK) <> 0 then
      mbs := mbs + [mbOK];
    {/v0.75}
    if (w and smYes) <> 0 then begin
      case MessageDlg(msg, {v0.75}mt {/v0.75 mtConfirmation}, mbs, hc) of
        mrYes : Result := cmYes;
        mrNo : Result := cmNo;
      else
        Result := cmCancel;
      end;
    end else begin
      MessageDlg(msg, {v0.75}mt{/v0.75 mtInformation}, mbs, hc);
      Result := cmOK;
    end;
    {/v0.62
    if ((w and smYesNo) = smYesNo) then begin
      if MessageDlg(msg, mtConfirmation, [mbYes, mbNo], hc) = mrYes then
        ShowMessage := cmYes
      else
        ShowMessage := cmNo;
    end else begin
      MessageDlg(msg, mtInformation, [mbOK], hc);
      ShowMessage := cmOK;
    end;
    }
  end;
end;


procedure SysError(msg:string);
begin
  if Assigned(SysErrorProc) then
    SysErrorProc(msg)
  else
    ShowMessage(msg, smError, 0);
end;

procedure SysOutput(msg:string);
begin
  if Assigned(SysOutputProc) then
    SysOutputProc(msg)
  else
    ShowMessage(msg, smInfo, 0);
end;


type
  {PProgressBox = ^TProgressBox;}
  TProgBox = class (TObject)
  public
    FProgressBoxCanceled:boolean;
    ProgressBoxCancelRequested:boolean;{modified by method ProgressBoxCancel,
      called by user if he wants to force to cancel action upon next ProgressBoxUpdate}
    UpdatingProgressBox:boolean;{to prevent recursion in SendMsgToApp... call}
    Txt:string;
    Progress:longint;{0..100}
    CurY:integer;{CRT screen position}
    SizeToDo, SizeDone:longint;
    SubSize:longint;
    LastX,LastY:longint;{from last update}

    constructor Create(const Msg:String);
    function Cancel:boolean;
    function Canceled:boolean;
    function Update(x,y:Longint):boolean;
    function WriteMsg(const Msg:string):boolean;
    destructor Destroy;override; {virtual;}
  end;

constructor TProgBox.Create(const Msg:string);
begin
  inherited Create;
  FProgressBoxCanceled:= false;
  ProgressBoxCancelRequested:= false;
  UpdatingProgressBox:= false;
  Txt:= Msg;
  Progress:= 0;
  SizeToDo :=0;
  SizeDone:=0;
  SubSize:= 0;
  LastX :=0;
  LastY := 0;
end;

function TProgBox.Cancel:boolean;
begin
  Cancel := true;
  FProgressBoxCanceled := true;
end;

function TProgBox.Canceled:boolean;
begin
  Canceled := FProgressBoxCanceled;
end;

function TProgBox.Update(x,y:Longint):boolean;
var i:integer;
begin
  Update := false;
  if y = 0 then
    exit;
  x := abs(x);
  y := abs(y);

  if x > y then
    exit;

  if y = SizeToDo then begin
    SizeDone := x;
    SubSize := 0;
  end else begin
    if (SizeToDo <> 0) then begin
      if (y <> SubSize) then begin
        inc(SizeDone, SubSize);
        SubSize := y;
      end;
      x := SizeDone + x;
      y := SizeToDo;
    end;
  end;

  i := round(x/y * 100);
  if i <> Progress then begin
    Progress := i;
    WriteMsg(Txt);
  end;
  Update := true;
  LastX := x;
  LastY := y;
end;

function TProgBox.WriteMsg(const Msg:string):boolean;
begin
  WriteMsg := false;
end;

destructor TProgBox.Destroy;
begin
  WriteMsg('');
  Update(100,100);
  inherited Destroy;
end;

var
  ProgBoxes: TList;

function IsValid(var AProgBox:pointer):boolean;
begin
  IsValid := false;
  if (ProgBoxes = nil) or (ProgBoxes.Count = 0) then
    exit;
  if AProgBox = DefaultProgressBox then begin
    AProgBox := ProgBoxes.Items[0];
    IsValid := true;
  end else begin
    IsValid := ((ProgBoxes.IndexOf(AProgBox) >= 0));
  end;
end;

{interface methods:}

function ProgressBoxShow(const Msg:string; ASizeToDo:longint):pointer;
var
  PB:TProgBox;
  cnt:integer;
label er;
begin
  ProgressBoxShow := nil;
  PB := nil;

  if ProgBoxes = nil then begin
    ProgBoxes := TList.Create;{New(PMCollection, Create(10, 5));}
    ProgBoxes.Capacity := 10;
  end;
  if ProgBoxes = nil then
    goto er;
  cnt := ProgBoxes.Count;

  PB := TProgBox.Create(Msg);
  if PB = nil then
    goto er;
  ProgBoxes.Add(PB);
  PB.SizeToDo := ASizeToDo;
  if cnt = ProgBoxes.Count then
    goto er;
  ProgressBoxShow := PB;
  exit;
er:
  if (ProgBoxes <> nil) and (ProgBoxes.Count = 0) then
    ClassFree(ProgBoxes);
  ClassFree(PB);
end;

function ProgressBoxHide(var AProgressBox:pointer):boolean;
begin
  ProgressBoxHide := false;
  if IsValid(AProgressBox) then begin
    ProgressBoxHide := true;
    ProgBoxes.Remove(AProgressBox);
    TProgBox(AProgressBox).Free;
    if ProgBoxes.Count = 0 then
      ClassFree(ProgBoxes);
    AProgressBox := nil;
  end;
end;

function ProgressBoxUpdate(AProgressBox:pointer; X,Y:longint):boolean;
begin
  ProgressBoxUpdate := false;
  if IsValid(AProgressBox) then begin
    ProgressBoxUpdate := TProgBox(AProgressBox).Update(X,Y);
  end;
end;

function ProgressBoxMsg(AProgressBox:pointer; const Msg:string; ASubSize:longint):boolean;
begin
  ProgressBoxMsg := false;
  if IsValid(AProgressBox) then begin
    ProgressBoxMsg := TProgBox(AProgressBox).WriteMsg(Msg);
  end;
end;

function ProgressBoxCancel(AProgressBox:pointer):boolean;
begin
  ProgressBoxCancel := false;
  if IsValid(AProgressBox) then begin
    ProgressBoxCancel := TProgBox(AProgressBox).Cancel;
  end;
end;

function ProgressBoxCanceled(AProgressBox:pointer):boolean;
begin
  ProgressBoxCanceled := false;
  if IsValid(AProgressBox) then begin
    ProgressBoxCanceled := TProgBox(AProgressBox).Canceled;
  end;
end;

function ProgressBox(var AProgressBox:TProgressBox; what:TProgressBoxAction;
  const Msg:string; X,Y:longint):TProgressBoxResult;
var PB:pointer  absolute AProgressBox;
begin
  if Assigned(ProgressBoxFn) then
    ProgressBox := ProgressBoxFn(AProgressBox, what, Msg, X,Y)
  else begin
    ProgressBox := 0;
    case what of
      pbShow : begin
        PB := pointer(ProgressBoxShow(Msg, Y));
        ProgressBox := longint(PB);
      end;
      pbHide : ProgressBox := longint(ProgressBoxHide(PB));
      pbUpdate: ProgressBox := longint(ProgressBoxUpdate(PB, X,Y));
      pbMsg : ProgressBox := longint(ProgressBoxMsg(PB, Msg, X));
      pbCancel: ProgressBox := longint(ProgressBoxCancel(PB));
      pbCanceled: ProgressBox := longint(ProgressBoxCanceled(PB));
    else
      begin
        SysError('ProgressBox unknown what');
      end;
    end;
  end;
end;

procedure SetMsgProc(AMsgProcType:TMsgProcType; AProc:pointer);
begin
  if (AMsgProcType = mtAll) then begin
    ShowMessageFn := nil;
    ProgressBoxFn := nil;
    SysErrorProc := nil;
  end else begin
    case AMsgProcType of
      mtShowMessage: @ShowMessageFn := AProc;
      mtProgressBox: @ProgressBoxFn := AProc;
      mtSysError: @SysErrorProc := AProc;
    end;
  end;
end;

function FileExistsOverwrite(const AFileName: string): boolean;
begin
  Result := true;
  if not FileExists(AFileName) then
    exit;
  if ShowMessage(GetTxt({#}'File') + ' ' + AFileName + ' ' + GetTxt({#}'Exists. Overwrite?'), smNoYes, 0) <> cmYes then
    Result := false;
end;

initialization
  ProgBoxes := nil;
end.
