config.pas

Turbo Pascal 6.0编译器源码

unit Config;

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

interface

uses Objects;

type

  PFDesktop = ^TFDesktop;
  TFDesktop = object(TCollection)
    constructor Init;
    function  GetItem(var S: TStream): Pointer; virtual;
    procedure InsertAll;
  end;

  PFEnvironment = ^TFEnvironment;
  TFEnvironment = object(TObject)
    constructor Load(var S: TStream);
    procedure Store(var S: TStream);
  end;

  PFCompiler = ^TFCompiler;
  TFCompiler = object(TObject)
    constructor Load(var S: TStream);
    procedure Store(var S: TStream);
  end;

  PFHistory = ^TFHistory;
  TFHistory = object(TObject)
    constructor Load(var S: TStream);
    procedure Store(var S: TStream);
  end;

  PFBreakpoints = ^TFBreakpoints;
  TFBreakpoints = object(TObject)
    constructor Load(var S: TStream);
    procedure Store(var S: TStream);
  end;

  PFColorTable = ^TFColorTable;
  TFColorTable = object(TObject)
    constructor Load(var S: TStream);
    procedure Store(var S: TStream);
  end;

  PFCommandTable = ^TFCommandTable;
  TFCommandTable = object(TObject)
    constructor Load(var S: TStream);
    procedure Store(var S: TStream);
  end;

procedure AutoSave;
function SaveConfig: Boolean;
function RetrieveConfig: Boolean;
function SaveDesktop: Boolean;
function RetrieveDesktop: Boolean;
function ClearDesktop: Boolean;

const

  RFDesktop: TStreamRec = (
    ObjType: 11000;
    VmtLink: Ofs(TypeOf(TFDesktop)^);
    Load:    @TFDesktop.Load;
    Store:   @TFDesktop.Store
  );
  RFEnvironment: TStreamRec = (
    ObjType: 11001;
    VmtLink: Ofs(TypeOf(TFEnvironment)^);
    Load:    @TFEnvironment.Load;
    Store:   @TFEnvironment.Store
  );
  RFCompiler: TStreamRec = (
    ObjType: 11002;
    VmtLink: Ofs(TypeOf(TFCompiler)^);
    Load:    @TFCompiler.Load;
    Store:   @TFCompiler.Store
  );
  RFHistory: TStreamRec = (
    ObjType: 11003;
    VmtLink: Ofs(TypeOf(TFHistory)^);
    Load:    @TFHistory.Load;
    Store:   @TFHistory.Store
  );
  RFBreakpoints: TStreamRec = (
    ObjType: 11004;
    VmtLink: Ofs(TypeOf(TFBreakpoints)^);
    Load:    @TFBreakpoints.Load;
    Store:   @TFBreakpoints.Store
  );
  RFColorTable: TStreamRec = (
    ObjType: 11005;
    VmtLink: Ofs(TypeOf(TFColorTable)^);
    Load:    @TFColorTable.Load;
    Store:   @TFColorTable.Store
  );
  RFCommandTable: TStreamRec = (
    ObjType: 11006;
    VmtLink: Ofs(TypeOf(TFCommandTable)^);
    Load:    @TFCommandTable.Load;
    Store:   @TFCommandTable.Store
  );

implementation

uses Drivers, Memory, HistList, Views, App, TDos, TVars, CompVars, TStatus,
  TWindows, Tracer, Editor, Utils, StrNames;

constructor TFDesktop.Init;
begin
  TCollection.Init(10, 10);
  Message(Desktop, evBroadcast, cmMakeDesktop, @Self);
end;

function TFDesktop.GetItem(var S: TStream): Pointer;
var
  P: Pointer;
begin
  GetItem := ValidView(PView(S.Get));
end;

procedure TFDesktop.InsertAll;

function DoInsert(P: PView): Boolean; far;
begin
  Desktop^.Insert(P);
  DoInsert := False;
end;

begin
  LastThat(@DoInsert);
end;

constructor TFEnvironment.Load(var S: TStream);
var
  I: Integer;
begin
  S.Read(DefTabSize, SizeOf(DefTabSize));
  S.Read(DefOptions, SizeOf(DefOptions));
  S.Read(BackupFiles, SizeOf(BackupFiles));
  SetOptions;
  S.Read(Preferences, SizeOf(Preferences));
  SetEgaLines(Preferences.ScreenSize <> 0);
  S.Read(RBAction, SizeOf(RBAction));
  S.Read(Doubledelay, SizeOf(Doubledelay));
  S.Read(MouseReverse, SizeOf(MouseReverse));
end;

procedure TFEnvironment.Store(var S: TStream);
begin
  S.Write(DefTabSize, SizeOf(DefTabSize));
  S.Write(DefOptions, SizeOf(DefOptions));
  S.Write(BackupFiles, SizeOf(BackupFiles));
  S.Write(Preferences, SizeOf(Preferences));
  S.Write(RBAction, SizeOf(RBAction));
  S.Write(Doubledelay, SizeOf(Doubledelay));
  S.Write(MouseReverse, SizeOf(MouseReverse));
end;

constructor TFCompiler.Load(var S: TStream);

procedure R(var P; Size: Word);
begin
  if S.Status = stOk then
    S.Read(P, Size);
end;

begin
  R(CompParams.Flags, SizeOf(Word));
  R(CompParams.Options, 4 * SizeOf(Word));
  R(Dirs, SizeOf(Dirs));
  R(CommandLine, SizeOf(CommandLine));
  R(DefinesStr, SizeOf(DefinesStr));
  R(ScreenSwapping, SizeOf(ScreenSwapping));
  R(MainFile, SizeOf(MainFile));
end;

procedure TFCompiler.Store(var S: TStream);
begin
  S.Write(CompParams.Flags, SizeOf(Word));
  S.Write(CompParams.Options, 4 * SizeOf(Word));
  S.Write(Dirs, SizeOf(Dirs));
  S.Write(CommandLine, SizeOf(CommandLine));
  S.Write(DefinesStr, SizeOf(DefinesStr));
  S.Write(ScreenSwapping, SizeOf(ScreenSwapping));
  S.Write(MainFile, SizeOf(MainFile));
end;

constructor TFHistory.Load(var S: TStream);
var
  I: Word;
begin
  if S.Status = stOk then
    S.Read(I, SizeOf(I));
  if S.Status = stOk then
  begin
    S.Read(HistoryBlock^, I);
    HistoryUsed := PtrRec(HistoryBlock).Ofs + I;
  end;
end;

procedure TFHistory.Store(var S: TStream);
var
  I: Word;
begin
  I := HistoryUsed - PtrRec(HistoryBlock).Ofs;
  S.Write(I, SizeOf(I));
  S.Write(HistoryBlock^, I);
end;

constructor TFBreakpoints.Load(var S: TStream);
var
  I: Integer;
begin
  if S.Status = stOk then
  begin
    S.Read(BptCount, SizeOf(BptCount));
    for I := 0 to BptCount - 1 do
    begin
      BptArr[I] := MemAlloc(SizeOf(BptArr[I]^));
      if BptArr[I] = nil then
      begin
        BptCount := I;
        Exit
      end;
      S.Read(BptArr[I]^, SizeOf(BptArr[I]^) - 8);
      if S.Status <> stOk then
      begin
        BptCount := I;
        Exit
      end;
    end;
  end;
  ConnectAllBpts;
end;

procedure TFBreakpoints.Store(var S: TStream);
var
  I: Integer;
begin
  S.Write(BptCount, SizeOf(BptCount));
  for I := 0 to BptCount - 1 do
    S.Write(BptArr[I]^, SizeOf(BptArr[I]^) - 8);
end;

constructor TFColorTable.Load(var S: TStream);
begin
  S.Read(ColorTable, SizeOf(ColorTable));
  DoneMemory;
  Application^.Redraw;
end;

procedure TFColorTable.Store(var S: TStream);
begin
  S.Write(ColorTable, SizeOf(ColorTable));
end;

constructor TFCommandTable.Load(var S: TStream);
var
  I: Integer;
  P: Pointer;
begin
  S.Read(I, SizeOf(I));
  P := MemAllocSeg(I);
  if P = nil then
  begin
    MessageBox(sNoMemoryForCommandTable, nil, mfWarning + mfOkButton);
    Exit
  end;
  PWordArray(P)^[0] := I;
  S.Read(PWordArray(P)^[1], I - 2);
  if DefCommandTable <> nil then
    FreeMem(DefCommandTable, PWordArray(DefCommandTable)^[0]);
  DefCommandTable := P;
  Message(Desktop, evConfig, cmUpdateCommandTable, P);
end;

procedure TFCommandTable.Store(var S: TStream);
begin
  S.Write(DefCommandTable^, PWordArray(DefCommandTable)^[0]);
end;

const
  MagicString = '$*#$$*#$';
  MagicNumber = $711;

function ReadHeader(var S: TStream; Header: string): Boolean;
var
  Test: string;
  I, J: Word;
begin
  ReadHeader := False;
  if S.GetSize <= Length(Header) + Length(MagicString) + 2 then
    Exit;
  S.Read(Test[1], Length(Header));
  Test[0] := Chr(Length(Header));
  if Test = Header then
  begin
    S.Read(Test[1], Length(MagicString));
    Test[0] := Chr(Length(MagicString));
    if Test = MagicString then
    begin
      S.Read(I, SizeOf(I));
      if I = MagicNumber then
        ReadHeader := S.Status = stOk;
    end;
  end;
end;

procedure WriteHeader(var S: TStream; Header: string);
var
  I: Word;
begin
  S.Write(Header[1], Length(Header));
  Header := MagicString;
  S.Write(Header[1], Length(Header));
  I := MagicNumber;
  S.Write(I, SizeOf(I));
end;

function SaveConfig: Boolean;
var
  Resource: TResourceFile;
  P: PObject;
  S: PStream;
begin
  SaveConfig := False;
  if ConfigFile='' then
    ConfigFile := Strings^.Get(sConfigFileName);
  S := New(PBufStream, Init(ConfigFile, stCreate, 1024));
  if S^.Status <> stOk then
  begin
    MessageBox(sCantCreateConfig, nil, mfError + mfOkButton);
    Exit
  end;
  StatusLine^.PrintStr(sWritingConfig, nil);
  WriteHeader(S^, 'Turbo Pascal Configuration File'^Z#0);
  if S^.Status = stOk then
  begin
    Resource.Init(S);
    P := New(PFEnvironment,Init);
    Resource.Put(P, 'Environment');
    Dispose(P, Done);
    P := New(PFCompiler, Init);
    Resource.Put(P, 'Compiler');
    Dispose(P, Done);
    P := New(PFColorTable, Init);
    Resource.Put(P, 'Colors');
    Dispose(P, Done);
    P := New(PFCommandTable, Init);
    Resource.Put(P, 'CommandTable');
    Dispose(P, Done);
  end;
  if S^.Status <> stOk then
  begin
    if S^.Status = stWriteError then
      MessageBox(sDiskFull, nil, mfError + mfOkButton)
    else
      MessageBox(sErrorWritingConfig, nil, mfError + mfOkButton);
    Resource.Done;
    FDelete(ConfigFile);
    Exit;
  end else
    Resource.Done;
  SaveConfig := True;
end;

function RetrieveConfig: Boolean;
var
  Resource: TResourceFile;
  P: PObject;
  S: PStream;
  I: Integer;
begin
  RetrieveConfig := False;
  if ConfigFile = '' then
    ConfigFile := Strings^.Get(sConfigFileName);
  SearchSysDir(ConfigFile);
  if ConfigFile <> '' then
  begin
    S := New(PBufStream, Init(ConfigFile, stOpenRead, 1024));
    if S^.Status <> stOk then
    begin
      MessageBox(sCantOpenConfig, nil, mfError + mfOkButton);
      Exit
    end;
    StatusLine^.PrintStr(sReadingConfig, nil);
    if not ReadHeader(S^, 'Turbo Pascal Configuration File'^Z#0) then
    begin
      MessageBox(sInvalidConfig, nil, mfError + mfOkButton);
      Exit
    end;
    Resource.Init(S);
    P := Resource.Get('Environment');
    Dispose(P, Done);
    P := Resource.Get('Compiler');
    Dispose(P, Done);
    P := Resource.Get('Colors');
    Dispose(P, Done);
    P := Resource.Get('CommandTable');
    Dispose(P, Done);
    if Resource.Stream^.Status <> stOk then
      MessageBox(sErrorReadingConfig, nil, mfError + mfOkButton);
    Resource.Done;
    RetrieveConfig := True;
  end;
end;

procedure GetDesktopName(var S: PathStr);
var
  Dir: DirStr;
  Name: NameStr;
  Ext: ExtStr;
begin
  S := '';
  if Preferences.DesktopFile<>0 then
  begin
    if ConfigFile = '' then
      ConfigFile := Strings^.Get(sConfigFileName);
    FSplit(ConfigFile, Dir, Name, Ext);
    if Preferences.DesktopFile = 2 then
      S := Dir;
    S := S + Name + '.DSK';
  end;
end;

function SaveDesktop: Boolean;
var
  Resource: TResourceFile;
  DesktopName: PathStr;
  P: PObject;
  S: PStream;
begin
  SaveDesktop := False;
  GetDesktopName(DesktopName);
  if DesktopName <> '' then
  begin
    S := New(PBufStream, Init(DesktopName, stCreate, 1024));
    if S^.Status <> stOk then
    begin
      MessageBox(sCantCreateDesktop, nil, mfError + mfOkButton);
      Exit
    end;
    StatusLine^.PrintStr(sWritingDesktop, nil);
    WriteHeader(S^, 'Turbo Pascal Desktop File'^Z#0);
    Resource.Init(S);
    P := New(PFDesktop, Init);
    Resource.Put(P, 'Desktop');
    PFDesktop(P)^.DeleteAll;
    Dispose(P, Done);
    P := New(PFHistory, Init);
    Resource.Put(P, 'History');
    Dispose(P, Done);
    P := New(PFBreakpoints, Init);
    Resource.Put(P, 'BreakPoints');
    Dispose(P, Done);
    if S^.Status <> stOk then
    begin
      if S^.Status = stWriteError then
        MessageBox(sDiskFull, nil, mfError + mfOkButton)
      else
        MessageBox(sErrorWritingDesktop, nil, mfError + mfOkButton);
      Resource.Done;
      FDelete(DesktopName);
    end else
      Resource.Done;
    SaveDesktop := True;
  end;
end;

function RetrieveDesktop:Boolean;
var
  Resource: TResourceFile;
  DesktopName: PathStr;
  D: PFDesktop;
  P: PObject;
  S: PStream;
  R: TRect;
begin
  RetrieveDesktop := False;
  if Desktop^.Valid(cmQuit) then
  begin
    GetDesktopName(DesktopName);
    if not FileExists(DesktopName) then
      Exit;
    S := New(PBufStream, Init(DesktopName, stOpenRead, 1024));
    StatusLine^.PrintStr(sReadingDesktop, nil);
    if not ReadHeader(S^, 'Turbo Pascal Desktop File'^Z#0) then
    begin
      MessageBox(sInvalidDesktop, nil, mfError + mfOkButton);
      Exit
    end;
    Resource.Init(S);
    if not ClearDesktop then
      Exit;
    D := PFDesktop(Resource.Get('Desktop'));
    D^.InsertAll;
    D^.DeleteAll;
    Dispose(D, Done);
    Application^.Insert(Desktop);
    P := Resource.Get('History');
    if P <> nil then
      Dispose(P, Done);
    P := Resource.Get('BreakPoints');
    if P <> nil then
      Dispose(P, Done);
    if Resource.Stream^.Status <> stOk then
      MessageBox(sErrorReadingDesktop, nil, mfError + mfOkButton);
    Resource.Done;
    RetrieveDesktop := True;
  end;
end;

procedure AutoSave;
begin
  if Preferences.AutoSave and asEditorFiles <> 0 then
    Message(Desktop, evEditor, cmSaveAll, nil);
  if Preferences.AutoSave and asEnvironment <> 0 then
    SaveConfig;
  if Preferences.AutoSave and asDesktop <> 0 then
    SaveDesktop;
end;

function ClearDesktop: Boolean;
var
  D: PFDesktop;
begin
  if not Desktop^.Valid(cmQuit) then
    ClearDesktop := False
  else
  begin
    D := New(PFDesktop, Init);
    if Clipboard <> nil then
      Clipboard^.Owner^.Hide;
    Dispose(D,Done);
    ClearHistory;
    DeleteAllBpts;
    ClearDesktop := True;
  end;
end;

end.