unit Msgu;
{$I DEFINE.PAS}{sys}
interface
uses
  {$IFDEF WINDOWS}
  Dialogs, Controls, Classes,
  {$ELSE}
  Crt,
  {$ENDIF}
  MyType, TVType, Stru, MyLib;


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}

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;}
begin
  if Assigned(ShowMessageFn) then
    ShowMessage := ShowMessageFn(msg, options, hc)
  else begin
    w := Options and $FF00;
    b := Options and $FF;{mytype}
    case b of

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

      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;

    end;
    {$IFNDEF WINDOWS}
    {$IFOPT I+} {$DEFINE IOON} {$ENDIF}
    {$I-}
    writeln(msg);
    i := ioresult;
    {$IFDEF IOON} {$I+} {$UNDEF IOON} {$ENDIF}{logu}

    {$ENDIF}
    if ((w and smYesNo) = smYesNo) then begin
      {$IFNDEF WINDOWS}
      ch := readkey;
      if ch in ['y','Y','a','A'] then
        ShowMessage := cmYes
      else
        ShowMessage := cmNo;
      {$ELSE}
      if MessageDlg(msg, mtConfirmation, [mbYes, mbNo], hc) = mrYes then
        ShowMessage := cmYes
      else
        ShowMessage := cmNo;
      {$ENDIF}
    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;
  {System.Rewrite(Output);}
  {System.Writeln(Msg);}
  {$IFNDEF WINDOWS}
  ClrScr;
  Writeln;
  Writeln(Msg);
  CurY:= WhereY;
  {$ENDIF}
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;
{$IFNDEF WINDOWS}
  var s:string;
{$ENDIF}
begin
  {$I-}
  {$IFNDEF WINDOWS}
  Writeln;
  GotoXY(1, CurY);
  ClrEol;
  Txt := Msg;
  s  := IToS(Progress, 3) + '% ' + Txt;
  Write(s);
  WriteMsg := true;
  {$ELSE}
  WriteMsg := false;
  {$ENDIF}
end;

destructor TProgBox.Destroy;
begin
  WriteMsg('');
  Update(100,100);
  {$IFNDEF WINDOWS}
    Writeln;
  {$ENDIF}
  inherited Destroy;
end;

const
  ProgBoxes:TList = nil;

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
    FreeObject(@ProgBoxes);
  FreeObject(@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
      FreeObject(@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;

end.
