www.pudn.com > tp60src.zip > CONFIG.PAS

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.