controls.pas

Turbo Pascal 6.0编译器源码

unit Controls;

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

interface

uses Objects, Drivers, Views, Dialogs, TVars;

const

  lfTop  = 0;
  lfLeft = $100;

  cmDeleteWindow = 1070;

  CDoubleTest = #7#8;

type

  PIntField = ^TIntField;
  TIntField = object(TInputLine)
    Min, Max: Longint;
    constructor Init(var Bounds: TRect; AMaxLen: Integer;
      AMin, AMax: Longint);
    constructor Load(var S: TStream);
    function DataSize: Word; virtual;
    procedure GetData(var Rec); virtual;
    procedure SetData(var Rec); virtual;
    procedure Store(var S: TStream);
    function Valid(Command: Word): Boolean; virtual;
  end;

  PCenterText = ^TCenterText;
  TCenterText = object(TStaticText)
    function DataSize: Word; virtual;
    procedure SetData(var Rec); virtual;
  end;

  PDoubleTest = ^TDoubleTest;
  TDoubleTest = object(TStaticText)
    Hilite: Boolean;
    function GetPalette: PPalette; virtual;
    procedure HandleEvent(var Event: TEvent); virtual;
    procedure Draw; virtual;
  end;

  PWindowListViewer = ^TWindowListViewer;
  TWindowListViewer = object(TListViewer)
    function DataSize: Word; virtual;
    procedure GetData(var Rec); virtual;
    function GetText(Item: Integer; MaxLen: Integer): string; virtual;
    procedure HandleEvent(var Event: TEvent); virtual;
    procedure SetData(var Rec); virtual;
    function WindowCount: Integer;
    function WindowNum(I: Integer): PWindow;
  end;

  PEditLine = ^TEditLine;
  TEditLine = object(TInputLine)
    CanExpand: Boolean;
    procedure HandleEvent(var Event: TEvent); virtual;
    procedure SetData(var Rec); virtual;
    function LegalCharSet: PCharSet; virtual;
  end;

  PAddressField = ^TAddressField;
  TAddressField = object(TInputLine)
    function DataSize: Word; virtual;
    procedure GetData(var Rec); virtual;
    procedure SetData(var Rec); virtual;
    function Valid(Command: Word): Boolean; virtual;
    function Value(var P: Pointer): Boolean;
  end;

  PCtrlPLine = ^TCtrlPLine;
  TCtrlPLine = object(TEditLine)
    procedure HandleEvent(var Event: TEvent); virtual;
  end;

const

  RIntField: TStreamRec = (
    ObjType: 2001;
    VmtLink: Ofs(TypeOf(TIntField)^);
    Load:    @TIntField.Load;
    Store:   @TIntField.Store
  );
  RCenterText: TStreamRec = (
    ObjType: 2002;
    VmtLink: Ofs(TypeOf(TCenterText)^);
    Load:    @TCenterText.Load;
    Store:   @TCenterText.Store
  );
  RDoubleTest: TStreamRec = (
    ObjType: 2003;
    VmtLink: Ofs(TypeOf(TDoubleTest)^);
    Load:    @TDoubleTest.Load;
    Store:   @TDoubleTest.Store
  );
  RWindowListViewer: TStreamRec = (
    ObjType: 2004;
    VmtLink: Ofs(TypeOf(TWindowListViewer)^);
    Load:    @TWindowListViewer.Load;
    Store:   @TWindowListViewer.Store
  );
  REditLine: TStreamRec = (
    ObjType: 2005;
    VmtLink: Ofs(TypeOf(TEditLine)^);
    Load:    @TEditLine.Load;
    Store:   @TEditLine.Store
  );
  RAddressField: TStreamRec = (
    ObjType: 2006;
    VmtLink: Ofs(TypeOf(TAddressField)^);
    Load:    @TAddressField.Load;
    Store:   @TAddressField.Store
  );
  RCtrlPLine: TStreamRec = (
    ObjType: 2007;
    VmtLink: Ofs(TypeOf(TCtrlPLine)^);
    Load:    @TCtrlPLine.Load;
    Store:   @TCtrlPLine.Store
  );

function NewButton(AX, AY, AW: Integer;ATitle: TTitleStr; ACommand: Word;
  AFlags: Byte; AHelpCtx: Word): PButton;
function OkButton(AX, AY: Integer): PButton;
function CnlButton(AX, AY: Integer): PButton;
function HelpButton(AX, AY: Integer; AHelpCtx: Word): PButton;
function StandardLabel(AText: string; ALink: PView; AFlags: Word): PLabel;
function StandardHistory(ALink: PInputLine; AHistoryId: Word): PHistory;
function SetHelp(P: PView; AHelpCtx: Word): PView;
function WindowListDialog: PDialog;

implementation

uses App, Utils, StrNames, Context;

constructor TIntField.Init(var Bounds: TRect; AMaxLen: Integer;
  AMin, AMax: Longint);
begin
  TInputLine.Init(Bounds, AMaxLen);
  Min := AMin;
  Max := AMax;
end;

constructor TIntField.Load(var S: TStream);
begin
  TInputLine.Load(S);
  S.Read(Min, SizeOf(Min) + SizeOf(Max));
end;

function TIntField.DataSize: Word;
begin
  DataSize := SizeOf(Longint);
end;

procedure TIntField.GetData(var Rec);
var
  Code: Integer;
begin
  Val(Data^, Longint(Rec), Code);
end;

procedure TIntField.SetData(var Rec);
begin
  Str(Longint(Rec), Data^);
  DrawView;
end;

procedure TIntField.Store(var S: TStream);
begin
  TInputLine.Store(S);
  S.Write(Min, SizeOf(Min) + SizeOf(Max));
end;

function TIntField.Valid(Command: Word): Boolean;
var
  Code: Integer;
  Value: Longint;
  L: array[0..5] of Longint;
begin
  Valid := True;
  if (Command <> cmCancel) and (Command <> cmValid) then
  begin
    Val(Data^, Value, Code);
    if (Code <> 0) or (Value < Min) or (Value > Max) then
    begin
      L[0] := Min;
      L[1] := Max;
      MessageBox(sValueNotInRange, @L, mfError + mfOkButton);
      SelectAll(True);
      Select;
      Valid := False;
    end;
  end;
end;

function TCenterText.DataSize: Word;
begin
  DataSize := SizeOf(string);
end;

procedure TCenterText.SetData(var Rec);
var
  R: string absolute Rec;
  S: string;
  I: Integer;
begin
  if Length(R) < Size.X then
  begin
    I := (Size.X - Length(R)) shr 1;
    FillChar(S[1], I, ' ');
    S[0] := Chr(I);
    S := S + R;
  end else
  begin
    S := R;
    S[0] := Chr(Size.X)
  end;
  DisposeStr(Text);
  Text := NewStr(S);
  DrawView;
end;

function TDoubleTest.GetPalette: PPalette;
const
  P: string[Length(CDoubleTest)] = CDoubleTest;
begin
  GetPalette := @P;
end;

procedure TDoubleTest.HandleEvent(var Event: TEvent);
begin
  TStaticText.HandleEvent(Event);
  if Event.What = evMouseDown then
  begin
    if Event.Double then
    begin
      Hilite := not Hilite;
      DrawView;
    end;
    ClearEvent(Event);
  end;
end;

procedure TDoubleTest.Draw;
var
  B: TDrawBuffer;
  Color: Byte;
begin
  if Hilite then
    Color := GetColor(2)
  else
    Color := GetColor(1);
  MoveChar(B, ' ', Color, Size.X);
  MoveStr(B, Text^, Color);
  WriteLine(0, 0, Size.X, 1, B);
end;

function TWindowListViewer.WindowCount: Integer;
var
  I: Integer;

procedure DoWindowCount(P: PView); far;
begin
  if (P^.State and sfVisible <> 0) and (P^.Options and ofSelectable <> 0) then
    Inc(I);
end;

begin
  I := 0;
  Desktop^.ForEach(@DoWindowCount);
  WindowCount := I;
end;

function TWindowListViewer.DataSize: Word;
begin
  DataSize := SizeOf(PWindow);
end;

procedure TWindowListViewer.GetData(var Rec);

function DoGetData(P: PView): Boolean; far;
begin
  DoGetData := False;
  if (P^.State and sfVisible <> 0) and (P^.Options and ofSelectable <> 0) then
    if Focused = 0 then
      DoGetData := True
    else
      Dec(Focused);
end;

begin
  PView(Rec) := Desktop^.FirstThat(@DoGetData);
end;

function TWindowListViewer.WindowNum(I: Integer): PWindow;

function DoWindowNum(P: PView): Boolean; far;
begin
  DoWindowNum := False;
  if (P^.State and sfVisible <> 0) and (P^.Options and ofSelectable <> 0) and
    (P <> PView(Owner)) then
    if I = 0 then
      DoWindowNum := True
    else
      Dec(I);
end;

begin
  WindowNum := PWindow(Desktop^.FirstThat(@DoWindowNum));
end;

function TWindowListViewer.GetText(Item: Integer; MaxLen: Integer): string;
var
  P: PWindow;
begin
  P := WindowNum(Item);
  if P <> nil then
    GetText := P^.GetTitle(MaxLen)
  else
    GetText := '';
end;

procedure TWindowListViewer.HandleEvent(var Event: TEvent);
var
  P: PWindow;
begin
  if (Event.What = evMouseDown) and Event.Double then
  begin
    Event.What := evCommand;
    Event.Command := cmOK;
    PutEvent(Event);
    ClearEvent(Event);
  end;
  if PDialog(Owner)^.Phase = phFocused then
    TListViewer.HandleEvent(Event);
  if ((Event.What = evCommand) and (Event.Command = cmDeleteWindow)) or
    ((Event.What = evKeyDown) and (Event.keycode = kbDel)) then
  begin
    P := WindowNum(Focused);
    if (P <> nil) and (Message(P, evCommand, cmClose, nil) <> nil) then
    begin
      SetRange(WindowCount);
      DrawView;
    end;
    ClearEvent(Event);
  end;
end;

procedure TWindowListViewer.SetData(var Rec);
begin
  SetRange(WindowCount);
  if Range > 1 then FocusItem(1);
end;

function WindowListDialog: PDialog;
var
  R: TRect;
  Dialog: PDialog;
  Control: PView;
begin
  R.Assign(15, 3, 67, 18);
  Dialog := New(PDialog, Init(R, 'Window List'));
  with Dialog^ do
  begin
    Options := Options or ofCentered;
    R.Assign(39, 3, 40, 13);
    Control := New(PScrollBar, Init(R));
    Insert(Control);
    R.Assign(3, 3, 39, 13);
    Control := SetHelp(New(PWindowListViewer,
      Init(R, 1, nil, PScrollBar(Control))), hcWindowListViewer);
    Control^.Options := Control^.Options or ofPostProcess;
    Insert(Control);
    Insert(StandardLabel('~W~indows', Control, lfTop));
    Insert(OkButton(40, 3));
    Insert(NewButton(40, 6, 10, '~D~elete', cmDeleteWindow, bfNormal,
      hcDeleteWindowButton));
    Insert(CnlButton(40, 9));
    Insert(HelpButton(40, 12, hcWindowListDialog));
    SelectNext(False);
  end;
  WindowListDialog := Dialog;
end;

procedure TEditLine.SetData(var Rec);
var
  R: string absolute Rec;
begin
  if Data^ = '' then
    if R = '' then
      Data ^:= GetEditWord(MaxLen, LegalCharSet)
    else Data^ := R;
  CanExpand := True;
end;

procedure TEditLine.HandleEvent(var Event: TEvent);
var
  I: Integer;
  C: Char;
begin
  I := Length(Data^);
  C := Event.CharCode;
  if CanExpand and (Event.What = evKeyDown) then
    case CtrlToArrow(Event.KeyCode) of
      kbRight:
        if Length(Data^) = CurPos then
        begin
          Event.CharCode := GetEditChar(CurPos + 1);
          Inc(I);
        end;
    end;
  TInputLine.HandleEvent(Event);
  Event.CharCode := C;
  CanExpand := CanExpand and (Length(Data^) = I);
end;

function TEditLine.LegalCharSet: PCharSet;
begin
  LegalCharSet := @WordChars;
end;

function TAddressField.DataSize: Word;
begin
  DataSize := SizeOf(Pointer);
end;

function TAddressField.Value(var P: Pointer): Boolean;
var
  I, Code1, Code2: Integer;
begin
  Value := False;
  I := Pos(':', Data^);
  if I <> 0 then
  begin
    Val('$' + Copy(Data^, 1, I - 1), PtrRec(P).Seg, Code1);
    Val('$' + Copy(Data^, I + 1, 255), PtrRec(P).Ofs, Code2);
    if Code1 + Code2 = 0 then
      Value := True;
  end;
end;

procedure TAddressField.GetData(var Rec);
begin
  Value(Pointer(Rec));
end;

procedure TAddressField.SetData(var Rec);
var
  L: array[0..1] of Longint;
begin
  L[0] := PtrRec(Rec).Seg;
  L[1] := PtrRec(Rec).Ofs;
  FormatStr(Data^, '%04x:%04x', L);
end;

function TAddressField.Valid(Command: Word): Boolean;
var
  P: Pointer;
begin
  Valid := True;
  if (Command <> cmCancel) and (Command <> cmValid) and not Value(P) then
  begin
    MessageBox(sInvalidAddress, nil, mfError + mfOkButton);
    SelectAll(True);
    Valid := False;
  end;
end;

procedure TCtrlPLine.HandleEvent(var Event: TEvent);

procedure DeleteSelect;
begin
  if SelStart <> SelEnd then
  begin
    Delete(Data^, SelStart + 1, SelEnd - SelStart);
    CurPos := SelStart;
  end;
end;

var
  I: Integer;
begin
  TEditLine.HandleEvent(Event);
  if (Event.What = evKeyDown) and (Event.CharCode = ^P) and
    (Length(Data^) < MaxLen) then
  begin
    KeyEvent(Event);
    if State and sfCursorIns <> 0 then
      Delete(Data^, CurPos + 1, 1)
    else
      DeleteSelect;
    if FirstPos > CurPos then
      FirstPos := CurPos;
    Inc(CurPos);
    Insert(Event.CharCode, Data^, CurPos);
    SelStart := 0;
    SelEnd := 0;
    if FirstPos > CurPos then
      FirstPos := CurPos;
    I := CurPos - Size.X + 2;
    if FirstPos < I then
      FirstPos := I;
    ClearEvent(Event);
    DrawView;
  end;
end;

function NewButton(AX, AY, AW: Integer; ATitle: TTitleStr; ACommand: Word;
  AFlags: Byte; AHelpCtx: Word): PButton;
var
  R: TRect;
begin
  R.Assign(AX, AY, AX + AW, AY + 2);
  NewButton := PButton(SetHelp(New(PButton,
    Init(R, ATitle, ACommand, AFlags)), AHelpCtx));
end;

function OkButton(AX, AY: Integer): PButton;
begin
  OkButton := NewButton(AX, AY, 10, 'O~K~', cmOK, bfDefault, hcOKButton);
end;

function CnlButton(AX, AY: Integer): PButton;
begin
  CnlButton := NewButton(AX, AY, 10, 'Cancel', cmCancel, bfNormal, hcCnlButton);
end;

function HelpButton(AX, AY: Integer; AHelpCtx: Word): PButton;
begin
  HelpButton := NewButton(AX, AY, 10, 'Help', cmHelp, bfNormal, AHelpCtx);
end;

function StandardLabel(AText: string; ALink: PView; AFlags: Word): PLabel;
var
  R: TRect;
begin
  ALink^.GetBounds(R);
  if AFlags and lfLeft <> 0 then
  begin
    if Lo(AFlags) = 0 then
    begin
      R.B.X := R.A.X - 1;
      Dec(R.A.X, CStrLen(AText) + 2);
    end else
    begin
      R.A.X := Lo(AFlags);
      R.B.X := R.A.X + CStrLen(AText) + 1;
    end;
  end else
  begin
    Dec(R.A.X);
    Dec(R.A.Y);
    R.B.X := R.A.X + CStrLen(AText) + 1;
    R.B.Y := R.A.Y + 1;
  end;
  R.B.Y := R.A.Y + 1;
  StandardLabel := New(PLabel, Init(R, AText, ALink));
end;

function StandardHistory(ALink: PInputLine; AHistoryId: Word): PHistory;
var
  R: TRect;
begin
  ALink^.GetBounds(R);
  R.A.X := R.B.X;
  Inc(R.B.X, 3);
  StandardHistory := New(PHistory, Init(R, ALink, AHistoryId));
end;

function SetHelp(P: PView; AHelpCtx: Word): PView;
begin
  P^.HelpCtx := AHelpCtx;
  SetHelp := P;
end;

end.