utils.pas

Turbo Pascal 6.0编译器源码

unit Utils;

{$O+,F+,S-,X+}

interface

uses Objects, Views, TDos, TVars;

type

  TResourceName = string[31];

const

  mfWarning      = $0000;
  mfError        = $0001;
  mfInformation  = $0002;
  mfAwarePoint   = $0010;
  mfYesButton    = $0100;
  mfNoButton     = $0200;
  mfOKButton     = $0400;
  mfCancelButton = $0800;

  mfYesNoCancel  = mfYesButton + mfNoButton + mfCancelButton;
  mfOKCancel     = mfOKButton + mfCancelButton;

function  MessageBox(Msg: Integer; Params: Pointer; AOptions: Word): Word;
procedure OutOfMemory;
function  ValidView(P: PView): PView;
function  LoadWindow(Name: TResourceName): PWindow;
function  ExecDialog(Name: TResourceName; Params: Pointer): Word;
function  WaitEvent: Word;
function  GetEditWord(MaxLen: Integer; CS: PCharSet): string;
function  GetEditChar(I: Integer): Char;
function  GetFreeWNum: Integer;
procedure ChangeSet(var T: TCommandSet; Command: Word; Enable: Boolean);
procedure SearchSysDir(var Name: PathStr);
function  ValidFileName(var Name: PathStr): Boolean;
procedure ChangeExt(var Path: PathStr; NewExt: ExtStr; Force: Boolean);
procedure SetEgaLines(Enable: Boolean);
function  DirExists(var Dir: DirStr): Boolean;

implementation

uses Drivers, Memory, Dialogs, App, TEdit, Editor, StrNames;

function MessageBox(Msg: Integer; Params: Pointer; AOptions: Word): Word;
const
  ButtonName: array[0..3] of string[6] =
    ('YesBtn', 'NoBtn', 'OkBtn', 'CnlBtn');
var
  I, X, ButtonCount: Integer;
  Dialog: PDialog;
  Control: PView;
  R: TRect;
  T: TRect;
  ButtonList: array[0..3] of PView;
  S: String;
  P: TPoint absolute Params;
begin
  R.Assign(0, 0, 40, 9);
  R.Move((Application^.Size.X - R.B.X) div 2,
         (Application^.Size.Y - R.B.Y) div 2);
  if AOptions and mfAwarePoint <> 0 then
  begin
    Desktop^.MakeGlobal(R.A, T.A);
    Desktop^.MakeGlobal(R.B, T.B);
    Dec(T.A.Y);
    Inc(T.B.Y);
    if (P.Y >= T.A.Y) and (P.Y <= T.B.Y) then
    begin
      I := R.B.Y - R.A.Y;
      if P.Y - I - 3 < 0 then
        R.A.Y := P.Y + 1
      else
        R.A.Y := P.Y - I - 2;
      R.B.Y := R.A.Y + I;
    end;
  end;
  Dialog := New(PDialog, Init(R, Strings^.Get((AOptions and $3) + sMsgBase)));
  with Dialog^ do
  begin
    R.Assign(3, 2, Size.X - 2, Size.Y - 3);
    FormatStr(S, Strings^.Get(Msg), Params^);
    Control := New(PStaticText, Init(R, S));
    Insert(Control);
    X := -2;
    ButtonCount := 0;
    for I := 0 to 3 do
      if AOptions and ($0100 shl I) <> 0 then
      begin
        Control := PView(Resource.Get(ButtonName[I]));
        Inc(X, Control^.Size.X + 2);
        ButtonList[ButtonCount] := Control;
        Inc(ButtonCount);
      end;
    X := (Size.X - X) shr 1;
    for I := 0 to ButtonCount - 1 do
    begin
      Control := ButtonList[I];
      Insert(Control);
      Control^.MoveTo(X, Size.Y - 3);
      Inc(X, Control^.Size.X + 2);
    end;
    SelectNext(False);
  end;
  MessageBox := Application^.ExecView(Dialog);
  Dispose(Dialog, Done);
end;

procedure OutOfMemory;
begin
  MessageBox(sOutOfMemory, nil, mfError + mfOkButton);
end;

function ValidView(P: PView): PView;
begin
  ValidView := nil;
  if P <> nil then
  begin
    if LowMemory then
    begin
      Dispose(P, Done);
      OutOfMemory
    end
    else if not P^.Valid(cmValid) then
      Dispose(P, Done)
    else
      ValidView := P;
  end;
end;

function LoadWindow(Name: TResourceName): PWindow;
var
  W: PWindow;
  L: array[0..0] of Longint;
begin
  W := PWindow(Resource.Get(Name));
  if W = nil then
  begin
    L[0] := Longint(@Name);
    MessageBox(sNoResource, @L, mfError + mfOkButton);
  end;
  LoadWindow:=PWindow(ValidView(W));
end;

function ExecDialog(Name: TResourceName; Params: Pointer): Word;
var
  D: PDialog;
  I: Word;
begin
  ExecDialog := cmCancel;
  D := PDialog(LoadWindow(Name));
  I := 0;
  if D <> nil then
  begin
    if Params <> nil then
      D^.SetData(Params^)
    else
      D^.SetData(I);
    I := Application^.ExecView(D);
    if (I <> cmCancel) and (Params <> nil) then
      D^.GetData(Params^);
    Dispose(D, Done);
    ExecDialog := I;
  end;
end;

function WaitEvent: Word; assembler;
asm
@@1:    CMP     ButtonCount,0
        JE      @@2
        MOV     AX,3
        INT     33H
        XOR     AX,AX
        OR      BL,BL
        JNZ     @@3
@@2:    MOV     AH,1
        INT     16H
        JZ      @@1
        MOV     AH,0
        INT     16H
        OR      AX,AX
        JZ      @@1
@@3:
end;

function GetEditChar(I: Integer): Char;
var
  C, CC: Char;
  P: PEditView;
  T: TPoint;
begin
  GetEditChar := #0;
  P := FindEditor(nil);
  if P <> nil then
  begin
    T := P^.Editor^.TempPos;
    C := #0;
    repeat
      CC := C;
      C := Char(P^.DoFunc(edGetOneChar));
      if C < ' ' then
        if C = #0 then
          Exit
        else
          C := ' ';
      if (C <> ' ') or (CC <> ' ') then
        Dec(I);
    until I = 0;
    GetEditChar := C;
    P^.Editor^.TempPos := T;
  end;
end;

function GetEditWord(MaxLen: Integer; CS: PCharSet): string;
var
  P: PEditView;
  SaveCursorPos, SaveScreenPos, SaveTempPos: TPoint;
  S: string;
  C: Char;
begin
  S := '';
  P := FindEditor(nil);
  if P <> nil then
    with P^ do
    begin
      SaveCursorPos := Editor^.CursorPos;
      SaveScreenPos.X := Editor^.ScreenPos.X;
      SaveScreenPos.Y := Editor^.ScreenPos.Y;
      if Editor^.CursorPos.X <> 1 then
      begin
        repeat
          DoFunc(edCursorCharLeft);
          DoFunc(edSetTempPos);
          C := Char(DoFunc(edGetOneChar));
        until (Editor^.CursorPos.X = 1) or not (C in CS^);
        if not (C in CS^) then
          DoFunc(edCursorCharRight);
      end;
      DoFunc(edSetTempPos);
      SaveTempPos := Editor^.TempPos;
      C := Char(DoFunc(edGetOneChar));
      while (C in CS^) and (length(S) < MaxLen) do
      begin
        Inc(S[0]);
        S[length(S)] := C;
        C := Char(DoFunc(edGetOneChar));
      end;
      Editor^.CursorPos := SaveCursorPos;
      Editor^.ScreenPos.X := SaveScreenPos.X;
      Editor^.ScreenPos.Y := SaveScreenPos.Y;
      Editor^.TempPos := SaveTempPos;
    end;
  GetEditWord := S;
end;

function GetFreeWNum: Integer;
var
  I: Integer;

function DoFind(P: PWindow): Boolean; far;
begin
  if (P^.Options and ofSelectable <> 0) and (P^.State and sfVisible <> 0) then
    DoFind := P^.Number = I
  else
    DoFind := False;
end;

begin
  I := 0;
  repeat
    Inc(I)
  until Desktop^.FirstThat(@DoFind) = nil;
  GetFreeWNum := I;
end;

procedure ChangeSet(var T: TCommandSet; Command: Word; Enable: Boolean);
begin
  if Enable then
    T := T + [Command]
  else
    T := T - [Command];
end;

procedure SearchSysDir(var Name: PathStr);
var
  Dir: DirStr;
  N: NameStr;
  Ext: ExtStr;
begin
  FSplit(TurboExe, Dir, N, Ext);
  Name := FSearch(Name, Dir);
end;

function ValidFileName(var Name: PathStr): Boolean;
var
  Dir: DirStr;
  N: NameStr;
  Ext: ExtStr;

function HasAny(S, S1: string): Boolean; near; assembler;
asm
        PUSH    DS
        CLD
        LDS     SI,S
        LES     DI,S1
        INC     DI
        MOV     DX,DI
        XOR     AH,AH
        LODSB
        MOV     BX,AX
        OR      BX,BX
        JZ      @@2
        MOV     AL,ES:[DI-1]
        XCHG    AX,CX
@@1:    PUSH    CX
        MOV     DI,DX
        LODSB
        REPNE   SCASB
        POP     CX
        JE      @@3
        DEC     BX
        JNZ     @@1
@@2:    XOR     AL,AL
        JMP     @@4
@@3:    MOV     AL,1
@@4:    POP     DS
end;

begin
  ValidFileName := True;
  if FileExists(Name) then
    Exit;
  FSplit(Name, Dir, N, Ext);
  if (Dir + N + Ext <> Name) or (Dir <> '') and not DirExists(Dir) or
    HasAny(N, ';,=+<>|"[] \') or
    HasAny(Copy(Ext, 2, 255), ';,=+<>|"[] \.') then
    ValidFileName := False;
end;

procedure ChangeExt(var Path: PathStr; NewExt: ExtStr; Force: Boolean);
var
  Dir: DirStr;
  Name: NameStr;
  Ext: ExtStr;
begin
  FSplit(Path, Dir, Name, Ext);
  if Force or (Ext = '') then
    Path := Dir + Name + NewExt;
end;

procedure SetEgaLines(Enable: Boolean);
var
  I: Word;
begin
  if HiResScreen and (Lo(ScreenMode) <> smMono) then
  begin
    if Enable then
      I := ScreenMode or smFont8x8
    else
      I := ScreenMode and not smFont8x8;
    if I <> ScreenMode then
      Application^.SetScreenMode(I);
  end;
end;

function DirExists(var Dir: DirStr): Boolean;
var
  S: PathStr;
begin
  FExpand(Dir, S);
  if Length(S) <= 3 then
    DirExists := (Length(S) > 1) and DriveValid(S[1])
  else
  begin
    if S[Length(S)] = '\' then Dec(S[0]);
    DirExists := GetFileAttr(S) > 0;
  end;
end;

end.