tstddlg.pas

Turbo Pascal 6.0编译器源码

unit TStdDlg;

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

interface

uses Objects, Drivers, Views, Dialogs, TDos;

const

  cmFileOpen    = 1010;
  cmFileReplace = 1011;
  cmFileClear   = 1012;
  cmFileInit    = 1013;
  cmChangeDir   = 1020;
  cmRevert      = 1021;


  cmFileFocused       = 102;
  cmFileDoubleClicked = 103;

type

  TSearchRec = record
    Attr: Byte;
    Time: Longint;
    Size: Longint;
    Name: string[12];
  end;

type

  PFileInputLine = ^TFileInputLine;
  TFileInputLine = object(TInputLine)
    constructor Init(var Bounds: TRect; AMaxLen: Integer);
    procedure HandleEvent(var Event: TEvent); virtual;
  end;

  PFileCollection = ^TFileCollection;
  TFileCollection = object(TSortedCollection)
    function Compare(Key1, Key2: Pointer): Integer; virtual;
    procedure FreeItem(Item: Pointer); virtual;
    function GetItem(var S: TStream): Pointer; virtual;
    procedure PutItem(var S: TStream; Item: Pointer); virtual;
  end;

  PSortedListBox = ^TSortedListBox;
  TSortedListBox = object(TListBox)
    SearchPos: Word;
    ShiftState: Byte;
    constructor Init(var Bounds: TRect; ANumCols: Word;
      AScrollBar: PScrollBar);
    procedure HandleEvent(var Event: TEvent); virtual;
    function GetKey(var S: String): Pointer; virtual;
    procedure NewList(AList: PCollection); virtual;
  end;

  PFileList = ^TFileList;
  TFileList = object(TSortedListBox)
    constructor Init(var Bounds: TRect; AWildCard: PathStr;
      AScrollBar: PScrollBar);
    destructor Done; virtual;
    function DataSize: Word; virtual;
    procedure FocusItem(Item: Integer); virtual;
    procedure GetData(var Rec); virtual;
    function GetText(Item: Integer; MaxLen: Integer): String; virtual;
    function GetKey(var S: String): Pointer; virtual;
    procedure HandleEvent(var Event: TEvent); virtual;
    procedure ReadDirectory(AWildCard: PathStr);
    procedure SetData(var Rec); virtual;
  end;

  PFileInfoPane = ^TFileInfoPane;
  TFileInfoPane = object(TView)
    S: TSearchRec;
    constructor Init(var Bounds: TRect);
    procedure Draw; virtual;
    function GetPalette: PPalette; virtual;
    procedure HandleEvent(var Event: TEvent); virtual;
  end;

  TWildStr = PathStr;

const

  fdOkButton      = $0001;
  fdOpenButton    = $0002;
  fdReplaceButton = $0004;
  fdClearButton   = $0008;

type

  PFileDialog = ^TFileDialog;
  TFileDialog = object(TDialog)
    FileName: PFileInputLine;
    FileList: PFileList;
    WildCard: TWildStr;
    Directory: PString;
    constructor Init(AWildCard: TWildStr; ATitle: String;
      InputName: String; AOptions: Word; HistoryId: Byte; AHelpCtx: Word);
    constructor Load(var S: TStream);
    destructor Done; virtual;
    procedure GetData(var Rec); virtual;
    procedure GetFileName(var S: PathStr);
    procedure HandleEvent(var Event: TEvent); virtual;
    procedure SetData(var Rec); virtual;
    procedure Store(var S: TStream);
    function Valid(Command: Word): Boolean; virtual;
  end;

  PDirListBox = ^TDirListBox;
  TDirListBox = object(TListBox)
    Dir: DirStr;
    Cur: Word;
    constructor Init(var Bounds: TRect; AScrollBar: PScrollBar);
    destructor Done; virtual;
    function GetText(Item: Integer; MaxLen: Integer): String; virtual;
    procedure HandleEvent(var Event: TEvent); virtual;
    function IsSelected(Item: Integer): Boolean; virtual;
    procedure NewDirectory(var ADir: DirStr);
    procedure SetState(AState: Word; Enable: Boolean); virtual;
  end;

type

  PChDirDialog = ^TChDirDialog;
  TChDirDialog = object(TDialog)
    DirInput: PInputLine;
    DirList: PDirListBox;
    OkButton: PButton;
    ChDirButton: PButton;
    constructor Init(HistoryId: Word);
    constructor Load(var S: TStream);
    function DataSize: Word; virtual;
    procedure GetData(var Rec); virtual;
    procedure HandleEvent(var Event: TEvent); virtual;
    procedure SetData(var Rec); virtual;
    procedure Store(var S: TStream);
    function Valid(Command: Word): Boolean; virtual;
  end;

PSecretCopyright = ^TSecretCopyright;
TSecretCopyright = object(TStaticText)
  constructor Init(var Bounds: TRect; AText: String);
  procedure HandleEvent(var Event: TEvent); virtual;
end;

PMouseDialog = ^TMouseDialog;
TMouseDialog = object(TDialog)
  ScrollBar: PscrollBar;
  DoubleDel: Word;
  constructor Init;
  constructor Load(var S: TStream);
  procedure HandleEvent(var Event: TEvent); virtual;
  procedure Store(var S: TStream);
end;

PHelpDialog = ^THelpDialog;
THelpDialog = object(TDialog)
  HelpView: PView;
  constructor Load(var S: TStream);
  function GetPalette: PPalette; virtual;
  procedure HandleEvent(var Event: TEvent); virtual;
  procedure Store(var S: TStream);
end;

PReplaceDialog = ^TReplaceDialog;
TReplaceDialog = object(TDialog)
  constructor Init;
  procedure HandleEvent(var Event: TEvent); virtual;
end;

PSizesDialog = ^TSizesDialog;
TSizesDialog = object(TDialog)
  LowHeap: PView;
  HighHeap: PView;
  constructor Init;
  constructor Load(var S: TStream);
  function Valid(Command: Word): Boolean; virtual;
  procedure Store(var S: TStream);
end;

const

  CInfoPane   = #30;
  CHelpDialog = #32#33#34#35#36#37#38#39#40#41#42#43#44#45#46#47 +
	        #48#49#50#51#52#53#54#55#56#57#58#59#60#61#62#63 +
	        #85#86#87#88#89#90#91#92;

  RFileInputLine: TStreamRec = (
     ObjType: 3001;
     VmtLink: Ofs(TypeOf(TFileInputLine)^);
     Load:    @TFileInputLine.Load;
     Store:   @TFileInputLine.Store
  );
  RFileCollection: TStreamRec = (
     ObjType: 3002;
     VmtLink: Ofs(TypeOf(TFileCollection)^);
     Load:    @TFileCollection.Load;
     Store:   @TFileCollection.Store
  );
  RFileList: TStreamRec = (
     ObjType: 3003;
     VmtLink: Ofs(TypeOf(TFileList)^);
     Load:    @TFileList.Load;
     Store:   @TFileList.Store
  );
  RFileInfoPane: TStreamRec = (
     ObjType: 3004;
     VmtLink: Ofs(TypeOf(TFileInfoPane)^);
     Load:    @TFileInfoPane.Load;
     Store:   @TFileInfoPane.Store
  );
  RFileDialog: TStreamRec = (
     ObjType: 3005;
     VmtLink: Ofs(TypeOf(TFileDialog)^);
     Load:    @TFileDialog.Load;
     Store:   @TFileDialog.Store
  );
  RDirListBox: TStreamRec = (
     ObjType: 3006;
     VmtLink: Ofs(TypeOf(TDirListBox)^);
     Load:    @TDirListBox.Load;
     Store:   @TDirListBox.Store
  );
  RChDirDialog: TStreamRec = (
     ObjType: 3007;
     VmtLink: Ofs(TypeOf(TChDirDialog)^);
     Load:    @TChDirDialog.Load;
     Store:   @TChDirDialog.Store
  );
  RSecretCopyright: TStreamRec = (
    ObjType: 3008;
    VmtLink: Ofs(TypeOf(TSecretCopyright)^);
    Load:    @TSecretCopyright.Load;
    Store:   @TSecretCopyright.Store
  );
  RMouseDialog: TStreamRec = (
    ObjType: 3090;
    VmtLink: Ofs(TypeOf(TMouseDialog)^);
    Load:    @TMouseDialog.Load;
    Store:   @TMouseDialog.Store
  );
  RHelpDialog: TStreamRec = (
    ObjType: 3091;
    VmtLink: Ofs(TypeOf(THelpDialog)^);
    Load:    @THelpDialog.Load;
    Store:   @THelpDialog.Store
  );
  RReplaceDialog: TStreamRec = (
    ObjType: 3092;
    VmtLink: Ofs(TypeOf(TReplaceDialog)^);
    Load:    @TReplaceDialog.Load;
    Store:   @TReplaceDialog.Store
  );
  RSizesDialog: TStreamRec = (
    ObjType: 3093;
    VmtLink: Ofs(TypeOf(TSizesDialog)^);
    Load:    @TSizesDialog.Load;
    Store:   @TSizesDialog.Store
  );

function  FindDialog: PDialog;
function  GotoLineDialog: PDialog;
function  FindProcDialog: PDialog;
function  FindErrorDialog: PDialog;
function  ParamsDialog: PDialog;
function  CompilerOptionsDialog: PDialog;
function  LinkerDialog: PDialog;
function  DebuggingDialog: PDialog;
function  DirectoriesDialog: PDialog;
function  PreferencesDialog: PDialog;
function  EditorOptionsDialog: PDialog;
function  StartupOptionsDialog: PDialog;
function  AboutDialog: PDialog;
function  GetInfoDialog: PDialog;

procedure RegisterTStdDlg;

implementation

uses Memory, HistList, App, Utils, TVars, Controls, Context, StrNames;

type
  PSearchRec = ^TSearchRec;

function IsWild(var S: String): Boolean;
begin
  IsWild := (Pos('?', S) > 0) or (Pos('*', S) > 0);
end;

function IsDir(var S: String): Boolean;
var
  SR: SearchRec;
begin
  if FindFirst(S, Directory, SR) = 0 then
    IsDir := SR.Attr and Directory <> 0
  else
    IsDir := False;
end;

function GetCurDir: DirStr;
var
  CurDir: DirStr;
begin
  CurDir := TDos.GetCurDir(#0);
  if Length(CurDir) <> 3 then
  asm
        LEA     DI,CurDir
        INC     BYTE PTR [DI]
        XOR     BX,BX
        MOV     BL,[DI]
        MOV     BYTE PTR [BX+DI],'\'
  end;
  GetCurDir := CurDir;
end;

constructor TFileInputLine.Init(var Bounds: TRect; AMaxLen: Integer);
begin
  TInputLine.Init(Bounds, AMaxLen);
  EventMask := EventMask or evBroadcast;
end;

procedure TFileInputLine.HandleEvent(var Event: TEvent);
var
  Dir: DirStr;
  Name: NameStr;
  Ext: ExtStr;
begin
  TInputLine.HandleEvent(Event);
  if (Event.What = evBroadcast) and (Event.Command = cmFileFocused) and
    (State and sfSelected = 0) then
  begin
     if PSearchRec(Event.InfoPtr)^.Attr and Directory <> 0 then
	Data^ := PSearchRec(Event.InfoPtr)^.Name + '\' +
	  PFileDialog(Owner)^.WildCard
     else
       Data^ := PSearchRec(Event.InfoPtr)^.Name;
     DrawView;
  end;
end;

function TFileCollection.Compare(Key1, Key2: Pointer): Integer;
begin
  if PSearchRec(Key1)^.Name = PSearchRec(Key2)^.Name then
    Compare := 0
  else if PSearchRec(Key1)^.Name = '..' then
    Compare := 1
  else if PSearchRec(Key2)^.Name = '..' then
    Compare := -1
  else if (PSearchRec(Key1)^.Attr and Directory <> 0) and
    (PSearchRec(Key2)^.Attr and Directory = 0) then
    Compare := 1
  else if (PSearchRec(Key2)^.Attr and Directory <> 0) and
    (PSearchRec(Key1)^.Attr and Directory = 0) then
    Compare := -1
  else if PSearchRec(Key1)^.Name > PSearchRec(Key2)^.Name then
    Compare := 1
  else
    Compare := -1;
end;

procedure TFileCollection.FreeItem(Item: Pointer);
begin
  Dispose(PSearchRec(Item));
end;

function TFileCollection.GetItem(var S: TStream): Pointer;
var
  Item: PSearchRec;
begin
  New(Item);
  S.Read(Item^, SizeOf(TSearchRec));
  GetItem := Item;
end;

procedure TFileCollection.PutItem(var S: TStream; Item: Pointer);
begin
  S.Write(Item^, SizeOf(TSearchRec));
end;

constructor TSortedListBox.Init(var Bounds: TRect; ANumCols: Word;
  AScrollBar: PscrollBar);
begin
  TListBox.Init(Bounds, ANumCols, AScrollBar);
  SearchPos := 0;
  ShowCursor;
  SetCursor(1, 0);
end;

procedure TSortedListBox.HandleEvent(var Event: TEvent);
var
  ShiftKeys: Byte absolute $40:$17;
  CurString, NewString: String;
  K: Pointer;
  Value, OldPos, OldValue: Integer;
  T: Boolean;

function Equal(var S1: String; var S2: String; Count: Word): Boolean;
var
  I: Word;
begin
  Equal := False;
  if (Length(S1) < Count) or (Length(S2) < Count) then
    Exit;
  for I := 1 to Count do
    if UpCase(S1[I]) <> UpCase(S2[I]) then
      Exit;
  Equal := True;
end;

begin
  OldValue := Focused;
  TListBox.HandleEvent(Event);
  if OldValue <> Focused then
    SearchPos := 0;
  if Event.What = evKeyDown then
  begin
    if Event.CharCode <> #0 then
    begin
      Value := Focused;
      if Value < Range then
        CurString := GetText(Value, 255)
      else
        CurString := '';
      OldPos := SearchPos;
      if Event.KeyCode = kbBack then
      begin
	if SearchPos = 0 then
          Exit;
	Dec(SearchPos);
	if SearchPos = 0 then
          ShiftState := ShiftKeys;
	CurString[0] := Char(SearchPos);
      end
      else if (Event.CharCode = '.') then
        SearchPos := Pos('.',CurString)
      else
      begin
	Inc(SearchPos);
	if SearchPos = 1 then
          ShiftState := ShiftKeys;
	CurString[0] := Char(SearchPos);
	CurString[SearchPos] := Event.CharCode;
      end;
      K := GetKey(CurString);
      T := PSortedCollection(List)^.Search(K, Value);
      if Value < Range then
      begin
	if Value < Range then
          NewString := GetText(Value, 255)
	else
          NewString := '';
	if Equal(NewString, CurString, SearchPos) then
	begin
	  if Value <> OldValue then
	  begin
	    FocusItem(Value);
	    SetCursor(Cursor.X + SearchPos, Cursor.Y);
	  end
	  else SetCursor(Cursor.X + (SearchPos - OldPos), Cursor.Y);
	end
	else SearchPos := OldPos;
      end
      else SearchPos := OldPos;
      if (SearchPos <> OldPos) or (Event.CharCode in ['A'..'Z', 'a'..'z']) then
	ClearEvent(Event);
    end;
  end;
end;

function TSortedListBox.GetKey(var S: String): Pointer;
begin
  GetKey := @S;
end;

procedure TSortedListBox.NewList(AList: PCollection);
begin
  TListBox.NewList(AList);
  SearchPos := 0;
end;

constructor TFileList.Init(var Bounds: TRect; AWildCard: PathStr;
  AScrollBar: PscrollBar);
begin
  TSortedListBox.Init(Bounds, 2, AScrollBar);
end;

destructor TFileList.Done;
begin
  if List <> nil then
    Dispose(List, Done);
  TListBox.Done;
end;

function TFileList.DataSize: Word;
begin
  DataSize := 0;
end;

procedure TFileList.FocusItem(Item: Integer);
begin
  TSortedListBox.FocusItem(Item);
  Message(Owner, evBroadcast, cmFileFocused, List^.At(Item));
end;

procedure TFileList.GetData(var Rec);
begin
end;

function TFileList.GetKey(var S: String): Pointer;
const
  SR: TSearchRec = ();

procedure UpStr(var S: String);
var
  I: Integer;
begin
  for I := 1 to Length(S) do
    S[I] := UpCase(S[I]);
end;

begin
  if (ShiftState and (kbRightShift + kbLeftShift) <> 0) or
    ((S <> '') and (S[1] = '.')) then
    SR.Attr := Directory
  else
    SR.Attr := 0;
  SR.Name := S;
  UpStr(SR.Name);