Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
1234 lines (1114 sloc) 29.5 KB
{/////////////////////////////////////////////////////////////////////////
//
// Dos Navigator Open Source 1.51.08
// Based on Dos Navigator (C) 1991-99 RIT Research Labs
//
// This programs is free for commercial and non-commercial use as long as
// the following conditions are aheared to.
//
// Copyright remains RIT Research Labs, and as such any Copyright notices
// in the code are not to be removed. If this package is used in a
// product, RIT Research Labs should be given attribution as the RIT Research
// Labs of the parts of the library used. This can be in the form of a textual
// message at program startup or in documentation (online or textual)
// provided with the package.
//
// Redistribution and use in source and binary forms, with or without
// modification, are permitted provided that the following conditions are
// met:
//
// 1. Redistributions of source code must retain the copyright
// notice, this list of conditions and the following disclaimer.
// 2. Redistributions in binary form must reproduce the above copyright
// notice, this list of conditions and the following disclaimer in the
// documentation and/or other materials provided with the distribution.
// 3. All advertising materials mentioning features or use of this software
// must display the following acknowledgement:
// "Based on Dos Navigator by RIT Research Labs."
//
// THIS SOFTWARE IS PROVIDED BY RIT RESEARCH LABS "AS IS" AND ANY EXPRESS
// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
// DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE FOR
// ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
// GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
// IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
// OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
// ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
//
// The licence and distribution terms for any publically available
// version or derivative of this code cannot be changed. i.e. this code
// cannot simply be copied and put under another distribution licence
// (including the GNU Public Licence).
//
//////////////////////////////////////////////////////////////////////////}
{$I STDEFINE.INC}
{$DEFINE NoCallspcb}
{-----------------------------------------------------}
{ This module is based on Turbo Vision Objects Unit }
{ Copyright (c) 1990 by Borland International }
{-----------------------------------------------------}
{AK155 = Alexey Korop, 2:461/155@fidonet}
{Cat = Aleksej Kozlov, 2:5030/1326.13@fidonet}
{Cat
28/08/2001 - ¯¥à¥¤¥« « áâப®¢ë¥ ª®««¥ªæ¨¨ ¤«ï ®¡¥á¯¥ç¥­¨ï ¢®§¬®¦­®áâ¨
åà ­¨âì ¢ ­¨å ­¥ ⮫쪮 String-¨, ­® ¨ LongString-¨
}
unit Collect;
interface
uses
Defines, Objects2, Streams
;
const
MaxCollectionSize = MaxBytes div SizeOf(Pointer);
{ TCollection error codes }
coIndexError = -1; { Index out of range }
coOverflow = -2; { Overflow }
type
PItemList = ^TItemList;
TItemList = array[0..MaxCollectionSize-1] of Pointer;
{ TCollection object }
PCollection = ^TCollection;
TCollection = object(TObject)
{Cat: íâ®â ®¡ê¥ªâ ¢ë­¥á¥­ ¢ ¯« £¨­­ãî ¬®¤¥«ì; ¨§¬¥­ïâì ªà ©­¥ ®áâ®à®¦­®!}
Items: PItemList;
Count: LongInt;
Limit: LongInt;
Delta: LongInt;
Status, ErrorInfo: Integer; {!!! ¢ OldColection}
constructor Init(ALimit, ADelta: LongInt);
constructor Load(var S: TStream);
destructor Done; virtual;
function At(Index: LongInt): Pointer;
procedure AtDelete(Index: LongInt);
procedure AtFree(Index: LongInt);
procedure AtInsert(Index: LongInt; Item: Pointer);
procedure AtPut(Index: LongInt; Item: Pointer);
procedure AtReplace(Index: LongInt; Item: Pointer);
procedure Delete(Item: Pointer);
procedure DeleteAll;
procedure Error(Code, Info: Integer); virtual;
function FirstThat(Test: Pointer): Pointer;
procedure ForEach(Action: Pointer);
procedure Free(Item: Pointer);
procedure FreeAll;
procedure FreeItem(Item: Pointer); virtual;
function GetItem(var S: TStream): Pointer; virtual;
function IndexOf(Item: Pointer): LongInt; virtual;
procedure Insert(Item: Pointer); virtual;
function LastThat(Test: Pointer): Pointer;
procedure Pack;
procedure PutItem(var S: TStream; Item: Pointer); virtual;
procedure SetLimit(ALimit: LongInt); virtual;
procedure Store(var S: TStream);
end;
{ TSortedCollection object }
PSortedCollection = ^TSortedCollection;
TSortedCollection = object(TCollection)
{Cat: íâ®â ®¡ê¥ªâ ¢ë­¥á¥­ ¢ ¯« £¨­­ãî ¬®¤¥«ì; ¨§¬¥­ïâì ªà ©­¥ ®áâ®à®¦­®!}
Duplicates: Boolean;
constructor Init(ALimit, ADelta: LongInt);
constructor Load(var S: TStream);
function Compare(Key1, Key2: Pointer): Integer; virtual;
function IndexOf(Item: Pointer): LongInt; virtual;
procedure Insert(Item: Pointer); virtual;
function KeyOf(Item: Pointer): Pointer; virtual;
function Search(Key: Pointer; var Index: LongInt): Boolean; virtual;
procedure Store(var S: TStream);
procedure Sort;
procedure QSort;
procedure QuickSort(L, R: LongInt);
end;
{ TLineCollection }
PLineCollection = ^TLineCollection;
TLineCollection = object(TCollection)
{Cat: íâ®â ®¡ê¥ªâ ¢ë­¥á¥­ ¢ ¯« £¨­­ãî ¬®¤¥«ì; ¨§¬¥­ïâì ªà ©­¥ ®áâ®à®¦­®!}
LongStrings: Boolean; {Cat}
constructor Init(ALimit, ADelta: LongInt; ALongStrings: Boolean);
{Cat}
procedure FreeItem(P: Pointer); virtual;
procedure PutItem(var S: TStream; Item: Pointer); virtual;
function GetItem(var S: TStream): Pointer; virtual;
end;
{ TStringCollection object }
PStringCollection = ^TStringCollection;
TStringCollection = object(TSortedCollection)
{Cat: íâ®â ®¡ê¥ªâ ¢ë­¥á¥­ ¢ ¯« £¨­­ãî ¬®¤¥«ì; ¨§¬¥­ïâì ªà ©­¥ ®áâ®à®¦­®!}
LongStrings: Boolean; {Cat}
constructor Init(ALimit, ADelta: LongInt; ALongStrings: Boolean);
{Cat}
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;
{ TStrCollection object }
PStrCollection = ^TStrCollection;
TStrCollection = object(TSortedCollection)
{Cat: íâ®â ®¡ê¥ªâ ¢ë­¥á¥­ ¢ ¯« £¨­­ãî ¬®¤¥«ì; ¨§¬¥­ïâì ªà ©­¥ ®áâ®à®¦­®!}
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;
{ TUnSortedStrCollection - UNSORTED STRING COLLECTION OBJECT }
{ This is a completely >> NEW << object which holds a collection of }
{ strings but does not alphabetically sort them. It is a very useful }
{ object for insert ordered list boxes! }
PUnSortedStrCollection = ^TUnSortedStrCollection;
TUnSortedStrCollection = object(TStringCollection)
procedure Insert(Item: Pointer); virtual;
end;
(*
{ TResourceCollection object }
PResourceCollection = ^TResourceCollection;
TResourceCollection = object(TStringCollection)
procedure FreeItem(Item: Pointer); virtual;
function GetItem(var S: TStream): Pointer; virtual;
function KeyOf(Item: Pointer): Pointer; virtual;
procedure PutItem(var S: TStream; Item: Pointer); virtual;
end;
{ TResourceFile object }
PResourceFile = ^TResourceFile;
TResourceFile = object(TObject)
Stream: PStream;
Modified: Boolean;
constructor Init(AStream: PStream);
destructor Done; virtual;
function Count: LongInt;
procedure Delete(Key: String);
procedure Flush;
function Get(Key: String): PObject;
function KeyAt(I: LongInt): String;
procedure Put(Item: PObject; Key: String);
function SwitchTo(AStream: PStream; Pack: Boolean): PStream;
private
BasePos: Longint;
IndexPos: Longint;
Index: TResourceCollection;
end;
*)
{ TStringList object }
TStrIndexRec = record
Key, Count, Offset: AWord;
end;
PStrIndex = ^TStrIndex;
TStrIndex = array[0..9999] of TStrIndexRec;
PStringList = ^TStringList;
TStringList = object(TObject)
constructor Load(var S: TStream);
destructor Done; virtual;
function Get(Key: AWord): String;
private
Stream: PStream;
BasePos: LongInt;
IndexSize: AWord;
Index: PStrIndex;
procedure ReadStr(var S: String; Offset, Skip: AWord);
end;
{-DataCompBoy-}
type
PDirCol = ^TDirCol;
TDirCol = object(TStringCollection)
function Compare(Key1, Key2: Pointer): Integer; virtual;
end;
{-DataCompBoy-}
implementation
uses
Memory,
Strings,
Advance1
;
constructor TCollection.Init(ALimit, ADelta: LongInt);
begin
inherited Init;
Delta := ADelta;
SetLimit(ALimit);
end;
constructor TCollection.Load(var S: TStream);
var
C, I: LongInt;
begin
TObject.Init;
S.Read(Count, SizeOf(Count));
S.Read(Limit, SizeOf(Limit));
S.Read(Delta, SizeOf(Delta));
if (Count > Limit) or (Delta < 0) then
Fail;
C := Count;
I := Limit;
Count := 0;
Limit := 0;
SetLimit(I);
for I := 0 to C-1 do
begin
AtInsert(I, GetItem(S));
if (S.Status <> stOK) then
begin
SetLimit(0);
Fail;
end;
end;
end { TCollection.Load };
function TCollection.At(Index: LongInt): Pointer;
begin
if (Index < 0) or (Index >= Count) or (Items = nil)
then
begin
Error(coIndexError, Index);
At := nil;
end
else
At := Items^[Index];
end;
procedure TCollection.AtDelete(Index: LongInt);
begin
if (Index >= 0) and (Index < Count) and (Items <> nil) then
begin
Dec(Count);
if Count > Index then
Move(Items^[Index+1], Items^[Index], (Count-Index)*SizeOf(Pointer));
end
else
Error(coIndexError, Index);
end;
procedure TCollection.AtInsert(Index: LongInt; Item: Pointer);
var
I: LongInt;
begin
if (Index >= 0) and (Index <= Count) then
begin
if Count = Limit then
SetLimit(Limit+Delta);
if Limit > Count then
begin
if Index < Count then
for I := Count-1 downto Index do
Items^[I+1] := Items^[I];
Items^[Index] := Item;
Inc(Count);
end
else
Error(coOverflow, Index);
end
else
Error(coIndexError, Index);
end;
procedure TCollection.AtPut(Index: LongInt; Item: Pointer);
begin
if (Index >= 0) and (Index < Count) and (Items <> nil)
then
Items^[Index] := Item
else
Error(coIndexError, Index);
end;
procedure TCollection.SetLimit(ALimit: LongInt);
var
AItems: PItemList;
begin
if ALimit < Count then
ALimit := Count;
if ALimit > MaxCollectionSize then
ALimit := MaxCollectionSize;
if ALimit <> Limit then
begin
if ALimit = 0 then
AItems := nil
else
begin
GetMem(AItems, ALimit*SizeOf(Pointer));
if (AItems <> nil) then
FillChar(AItems^, ALimit*SizeOf(Pointer), #0);
end;
if (AItems <> nil) or (ALimit = 0) then
begin
if (AItems <> nil) and (Items <> nil) and (Count <> 0) then
Move(Items^, AItems^, Count*SizeOf(Pointer));
if (Limit <> 0) and (Items <> nil) then
FreeMem(Items, Limit*SizeOf(Pointer));
end;
Items := AItems;
Limit := ALimit;
end;
end { TCollection.SetLimit };
destructor TCollection.Done;
begin
FreeAll;
SetLimit(0);
end;
procedure TCollection.AtFree(Index: LongInt);
var
Item: Pointer;
begin
Item := At(Index);
AtDelete(Index);
FreeItem(Item);
end;
procedure TCollection.AtReplace;
var
P: Pointer;
begin
if (Limit < Index) and (Delta > 0) then
SetLimit(Index+1);
while Count < (Index+1) do
Insert(nil);
P := At(Index);
AtPut(Index, Item);
if P <> nil then
FreeItem(P);
end;
procedure TCollection.Delete(Item: Pointer);
begin
AtDelete(IndexOf(Item));
end;
procedure TCollection.DeleteAll;
begin
if @Self <> nil then
Count := 0;
end;
procedure TCollection.Error(Code, Info: Integer);
begin
Status := Code;
ErrorInfo := Info;
{RunError(212 - Code);}
end;
{AK155: replace with TCollection.FirstThat from VP2.1 Objects.pas }
function TCollection.FirstThat(Test: Pointer): Pointer;
assembler; {$USES ebx}
{$FRAME-}
asm
mov edx,Self
mov ecx,[edx].TCollection.Count
jecxz @@3
mov ebx,Test
mov edx,[edx].TCollection.Items
@@1:
push edx
push ecx
push DWord Ptr [edx] { [1]:Pointer = Item }
Call ebx
pop ecx
pop edx
test al,al
jnz @@2
add edx,4
loop @@1
jmp @@3
@@2:
mov ecx,[edx]
@@3:
mov eax,ecx
end; {/AK155}
{AK155: pick ForEach from VP 2.1.231 RTL source}
procedure TCollection.ForEach(Action: Pointer);
assembler; {$USES ebx}
{$FRAME-}
asm
mov edx,Self
mov ecx,[edx].TCollection.Count
jecxz @@2
mov ebx,Action
mov edx,[edx].TCollection.Items
@@1:
push edx
push ecx
push DWord Ptr [edx] { [1]:Pointer = Item }
Call ebx
pop ecx
pop edx
add edx,4
loop @@1
@@2:
end; {/AK155}
procedure TCollection.Free(Item: Pointer);
begin
Delete(Item);
FreeItem(Item);
end;
procedure TCollection.FreeAll;
var
I: LongInt;
begin
for I := Count-1 downto 0 do
FreeItem(At(I));
Count := 0;
end;
procedure TCollection.FreeItem(Item: Pointer);
begin
FreeObject(Item);
end;
function TCollection.GetItem(var S: TStream): Pointer;
begin
GetItem := S.Get;
end;
function TCollection.IndexOf(Item: Pointer): LongInt;
var
I: LongInt;
begin
IndexOf := -1;
for I := 0 to Count-1 do
if At(I) = Item then
begin
IndexOf := I;
Break;
end;
end;
procedure TCollection.Insert(Item: Pointer);
begin
AtInsert(Count, Item);
end;
function TCollection.LastThat(Test: Pointer): Pointer;
assembler; {$USES ebx}
{$FRAME-} {AK155}
asm
mov edx,Self
mov ecx,[edx].TCollection.Count
jecxz @@3
mov edx,[edx].TCollection.Items
lea edx,[edx+ecx*4]
mov ebx,Test
@@1:
sub edx,4
push edx
push ecx
push DWord Ptr [edx] { [1]:Pointer = Item }
Call ebx
pop ecx
pop edx
test al,al
jnz @@2
loop @@1
jmp @@3
@@2:
mov ecx,[edx]
@@3:
mov eax,ecx
end; {/AK155}
procedure TCollection.Pack;
var
I: LongInt;
begin
for I := Count-1 downto 0 do
if At(I) = nil then
AtDelete(I);
end;
procedure TCollection.PutItem(var S: TStream; Item: Pointer);
begin
S.Put(Item);
end;
procedure TCollection.Store(var S: TStream);
procedure DoPutItem(P: Pointer);
begin
PutItem(S, P);
end;
begin
S.Write(Count, SizeOf(Count));
S.Write(Limit, SizeOf(Limit));
S.Write(Delta, SizeOf(Delta));
ForEach(@DoPutItem);
end;
{ TSortedCollection }
constructor TSortedCollection.Init(ALimit, ADelta: LongInt);
begin
TCollection.Init(ALimit, ADelta);
Duplicates := False;
end;
constructor TSortedCollection.Load(var S: TStream);
begin
inherited Load(S);
S.Read(Duplicates, SizeOf(Duplicates));
end;
function TSortedCollection.Compare(Key1, Key2: Pointer): Integer;
begin
end;
function TSortedCollection.IndexOf(Item: Pointer): LongInt;
var
I: LongInt;
begin
IndexOf := -1;
if Search(KeyOf(Item), I) then
begin
if Duplicates then
while (I < Count) and (Item <> At(I)) do
Inc(I);
if I < Count then
IndexOf := I;
end;
end;
procedure TSortedCollection.Insert(Item: Pointer);
var
I: LongInt;
begin
if not Search(KeyOf(Item), I) or Duplicates then
AtInsert(I, Item);
end;
function TSortedCollection.KeyOf(Item: Pointer): Pointer;
begin
KeyOf := Item;
end;
function TSortedCollection.Search
(Key: Pointer; var Index: LongInt): Boolean;
var
L, H, I, C: LongInt;
begin
Search := False;
L := 0;
H := Count-1;
while L <= H do
begin
I := (L+H) shr 1;
C := Compare(KeyOf(At(I)), Key);
if C < 0
then
L := I+1
else
begin
if C = 0 then
begin
Search := True;
if not Duplicates then
L := I;
Break;
end;
H := I-1;
end;
end;
Index := L;
end { TSortedCollection.Search };
procedure TSortedCollection.Store(var S: TStream);
begin
TCollection.Store(S);
S.Write(Duplicates, SizeOf(Duplicates));
end;
{ TStringCollection }
{Cat: ¤®¡ ¢¨« ¢®§¬®¦­®áâì åà ­¨âì ¢ ª®««¥ªæ¨¨ ¤«¨­­ë¥ áâப¨}
constructor TStringCollection.Init(ALimit, ADelta: LongInt;
ALongStrings: Boolean);
begin
inherited Init(ALimit, ADelta);
LongStrings := ALongStrings;
end;
function TStringCollection.Compare(Key1, Key2: Pointer): Integer;
var
I, J: LongInt;
P1, P2: PString;
PL1, PL2: PLongString;
begin
if LongStrings then
begin
PL1 := PLongString(Key1);
PL2 := PLongString(Key2);
if Length(PL1^) < Length(PL2^) then
J := Length(PL1^)
else
J := Length(PL2^);
I := 1;
while (I < J) and (PL1^[I] = PL2^[I]) do
Inc(I);
if (I = J) then
begin
if (PL1^[I] < PL2^[I]) then
Compare := -1
else if (PL1^[I] > PL2^[I]) then
Compare := 1
else if Length(PL1^) > Length(PL2^) then
Compare := 1
else if Length(PL1^) < Length(PL2^) then
Compare := -1
else
Compare := 0;
end
else if (PL1^[I] < PL2^[I]) then
Compare := -1
else
Compare := 1;
end
else
begin
P1 := PString(Key1);
P2 := PString(Key2);
if Length(P1^) < Length(P2^) then
J := Length(P1^)
else
J := Length(P2^);
I := 1;
while (I < J) and (P1^[I] = P2^[I]) do
Inc(I);
if (I = J) then
begin
if (P1^[I] < P2^[I]) then
Compare := -1
else if (P1^[I] > P2^[I]) then
Compare := 1
else if Length(P1^) > Length(P2^) then
Compare := 1
else if Length(P1^) < Length(P2^) then
Compare := -1
else
Compare := 0;
end
else if (P1^[I] < P2^[I]) then
Compare := -1
else
Compare := 1;
end;
end { TStringCollection.Compare };
procedure TStringCollection.FreeItem(Item: Pointer);
begin
if LongStrings then
DisposeLongStr(PLongString(Item))
else
DisposeStr(PString(Item));
end;
function TStringCollection.GetItem(var S: TStream): Pointer;
begin
if LongStrings then
GetItem := S.ReadLongStr
else
GetItem := S.ReadStr;
end;
procedure TStringCollection.PutItem(var S: TStream; Item: Pointer);
begin
if LongStrings then
S.WriteLongStr(Item)
else
S.WriteStr(Item);
end;
{/Cat}
{ TLineCollection }
{Cat: ¤®¡ ¢¨« ¢®§¬®¦­®áâì åà ­¨âì ¢ ª®««¥ªæ¨¨ ¤«¨­­ë¥ áâப¨}
constructor TLineCollection.Init(ALimit, ADelta: LongInt;
ALongStrings: Boolean);
begin
inherited Init(ALimit, ADelta);
LongStrings := ALongStrings;
end;
procedure TLineCollection.FreeItem(P: Pointer);
begin
if LongStrings then
DisposeLongStr(PLongString(P))
else
DisposeStr(PString(P));
end;
procedure TLineCollection.PutItem;
begin
if LongStrings then
S.WriteLongStr(Item)
else
S.WriteStr(Item);
end;
function TLineCollection.GetItem;
begin
if LongStrings then
GetItem := S.ReadLongStr
else
GetItem := S.ReadStr;
end;
{ TStrCollection }
function TStrCollection.Compare(Key1, Key2: Pointer): Integer;
begin
Compare := StrComp(Key1, Key2);
end;
procedure TStrCollection.FreeItem(Item: Pointer);
begin
StrDispose(PChar(Item));
end;
function TStrCollection.GetItem(var S: TStream): Pointer;
begin
GetItem := S.StrRead;
end;
procedure TStrCollection.PutItem(var S: TStream; Item: Pointer);
begin
S.StrWrite(Item);
end;
procedure TUnSortedStrCollection.Insert(Item: Pointer);
begin
AtInsert(Count, Item);
end;
(*
{ Private resource manager types }
const
RStreamMagic: Longint = $52504246; { 'FBPR' }
RStreamBackLink: Longint = $4C424246; { 'FBBL' }
type
PResourceItem = ^TResourceItem;
TResourceItem = record
Posn: Longint;
Size: Longint;
Key: String;
end;
{ TResourceCollection }
procedure TResourceCollection.FreeItem(Item: Pointer);
begin
FreeMem(Item, Length(PResourceItem(Item)^.Key) +
(SizeOf(TResourceItem) - SizeOf(String) + 1));
end;
function TResourceCollection.GetItem(var S: TStream): Pointer;
var
Pos: Longint;
Size: Longint;
L: Byte;
P: PResourceItem;
begin
S.Read(Pos, SizeOf(Pos));
S.Read(Size, SizeOf(Size));
{Cat:warn AnsiString}
S.Read(L, 1);
GetMem(P, L + (SizeOf(TResourceItem) - SizeOf(String) + 1));
P^.Posn:=Pos;
P^.Size:=Size;
SetLength(P^.Key, L);
S.Read(P^.Key[1], L);
GetItem:=P;
end;
function TResourceCollection.KeyOf(Item: Pointer): Pointer;
begin
KeyOf:=@PResourceItem(Item)^.Key; { Pointer to key }
end;
procedure TResourceCollection.PutItem(var S: TStream; Item: Pointer);
begin
S.Write(PResourceItem(Item)^, Length(PResourceItem(Item)^.Key) +
(SizeOf(TResourceItem) - SizeOf(String) + 1));
end;
{ TResourceFile }
constructor TResourceFile.Init(AStream: PStream);
type
{$IFDEF NewExeFormat}
TExeHeader = record
eHdrSize: Word;
eMinAbove: Word;
eMaxAbove: Word;
eInitSS: Word;
eInitSP: Word;
eCheckSum: Word;
eInitPC: Word;
eInitCS: Word;
eRelocOfs: Word;
eOvlyNum: Word;
eRelocTab: Word;
eSpace: Array[1..30] of Byte;
eNewHeader: Word;
end;
{$ENDIF}
THeader = record
Signature: Word;
case Integer of
0: (
LastCount: Word;
PageCount: Word;
ReloCount: Word);
1: (
InfoType: Word;
InfoSize: Longint);
end;
var
Found, Stop: Boolean;
Header: THeader;
{$IFDEF NewExeFormat}
ExeHeader: TExeHeader;
{$ENDIF}
begin
TObject.Init;
Stream:=AStream;
Found:=False;
if (Stream<>Nil) then begin
BasePos:=Stream^.GetPos;
repeat
Stop:=True;
if BasePos <= Stream^.GetSize - SizeOf(THeader) then
begin
Stream^.Seek(BasePos);
Stream^.Read(Header, SizeOf(THeader));
case Header.Signature of
{$IFDEF NewExeFormat}
$5A4D:
begin
Stream^.Read(ExeHeader, SizeOf(TExeHeader));
BasePos:=ExeHeader.eNewHeader;
Stop:=False;
end;
$454E:
begin
BasePos:=Stream^.GetSize - 8;
Stop:=False;
end;
$4246:
begin
Stop:=False;
case Header.Infotype of
$5250: {Found Resource}
begin
Found:=True;
Stop:=True;
end;
$4C42: Dec(BasePos, Header.InfoSize - 8); {Found BackLink}
$4648: Dec(BasePos, SizeOf(THeader) * 2); {Found HelpFile}
else
Stop:=True;
end;
end;
$424E:
if Header.InfoType = $3230 then {Found Debug Info}
begin
Dec(BasePos, Header.InfoSize);
Stop:=False;
end;
{$ELSE}
$5A4D:
begin
Inc(BasePos, LongMul(Header.PageCount, 512) -
(-Header.LastCount and 511));
Stop:=False;
end;
$4246:
if Header.InfoType = $5250 then Found:=True else
begin
Inc(BasePos, Header.InfoSize + 8);
Stop:=False;
end;
{$ENDIF}
end;
end;
until Stop;
end;
if Found then
begin
Stream^.Seek(BasePos + SizeOf(Longint) * 2);
Stream^.Read(IndexPos, SizeOf(Longint));
Stream^.Seek(BasePos + IndexPos);
Index.Load(Stream^);
end else
begin
IndexPos:=SizeOf(Longint) * 3;
Index.Init(0, 8);
end;
end;
destructor TResourceFile.Done;
begin
Flush;
Index.Done;
If (Stream <> nil) then Dispose(Stream,Done); Stream:=nil;
end;
function TResourceFile.Count: LongInt;
begin
Count:=Index.Count;
end;
procedure TResourceFile.Delete(Key: String);
var
I: LongInt;
begin
if Index.Search(@Key, I) then
begin
Index.Free(Index.At(I));
Modified:=True;
end;
end;
procedure TResourceFile.Flush;
var
ResSize: Longint;
LinkSize: Longint;
begin
if Modified and (Stream <> nil) then
begin
Stream^.Seek(BasePos + IndexPos);
Index.Store(Stream^);
ResSize:=Stream^.GetPos - BasePos;
LinkSize:=ResSize + SizeOf(Longint) * 2;
Stream^.Write(RStreamBackLink, SizeOf(Longint));
Stream^.Write(LinkSize, SizeOf(Longint));
Stream^.Seek(BasePos);
Stream^.Write(RStreamMagic, SizeOf(Longint));
Stream^.Write(ResSize, SizeOf(Longint));
Stream^.Write(IndexPos, SizeOf(Longint));
Stream^.Flush;
end;
Modified:=False;
end;
function TResourceFile.Get(Key: String): PObject;
var
I: LongInt;
begin
if (Stream = nil) or (not Index.Search(@Key, I)) then Get:=nil else
begin
Stream^.Seek(BasePos + PResourceItem(Index.At(I))^.Posn);
Get:=Stream^.Get;
end;
end;
function TResourceFile.KeyAt(I: LongInt): String;
begin
KeyAt:=PResourceItem(Index.At(I))^.Key;
end;
procedure TResourceFile.Put(Item: PObject; Key: String);
var
I: LongInt;
P: PResourceItem;
begin
if Stream = Nil Then Exit;
if Index.Search(@Key, I) then P:=Index.At(I) else
begin
GetMem(P, Length(Key) + (SizeOf(TResourceItem) - SizeOf(String) + 1));
if (P <> nil) then begin
P^.Key:=Key;
Index.AtInsert(I, P);
end;
end;
If (P <> nil) Then Begin
P^.Posn:=IndexPos;
Stream^.Seek(BasePos + IndexPos);
Stream^.Put(Item);
IndexPos:=Stream^.GetPos - BasePos;
P^.Size:=IndexPos - P^.Posn;
Modified:=True;
end;
end;
function TResourceFile.SwitchTo(AStream: PStream; Pack: Boolean): PStream;
var
NewBasePos: Longint;
procedure DoCopyResource(Item: PResourceItem);
{$IFDEF BIT_16} far; {$ENDIF}
begin
Stream^.Seek(BasePos + Item^.Posn);
Item^.Posn:=AStream^.GetPos - NewBasePos;
AStream^.CopyFrom(Stream^, Item^.Size);
end;
begin
SwitchTo:=Stream;
If (AStream <> Nil) AND (Stream <> Nil) then begin
NewBasePos:=AStream^.GetPos;
if Pack then
begin
AStream^.Seek(NewBasePos + SizeOf(Longint) * 3);
Index.ForEach(@DoCopyResource);
IndexPos:=AStream^.GetPos - NewBasePos;
end else
begin
Stream^.Seek(BasePos);
AStream^.CopyFrom(Stream^, IndexPos);
end;
Stream:=AStream;
Modified:=True;
BasePos:=NewBasePos;
end;
end;
*)
{ TStringList }
constructor TStringList.Load(var S: TStream);
var
Size: AWord;
begin
TObject.Init;
Stream := @S;
S.Read(Size, SizeOf(Size));
BasePos := i32(S.GetPos);
S.Seek(BasePos+Size);
S.Read(IndexSize, SizeOf(IndexSize));
GetMem(Index, IndexSize*SizeOf(TStrIndexRec));
S.Read(Index^, IndexSize*SizeOf(TStrIndexRec));
end;
destructor TStringList.Done;
begin
FreeMem(Index, IndexSize*SizeOf(TStrIndexRec));
end;
function TStringList.Get(Key: AWord): String;
var
I: AWord;
S: String;
begin
S := '';
if (IndexSize > 0) then
begin
I := 0;
while (I < IndexSize) and (S = '') do
begin
if ( (Key-Index^[I].Key) < Index^[I].Count) then
ReadStr(S, Index^[I].Offset, Key-Index^[I].Key);
Inc(I);
end;
end;
Get := S;
end;
procedure TStringList.ReadStr(var S: String; Offset, Skip: AWord);
{
var
B: Byte; }
begin
Stream^.Seek(BasePos+Offset);
Stream^.Status := 0;
Inc(Skip);
repeat
{Cat}
(*
Stream^.Read(B, 1);
SetLength(S, B);
Stream^.Read(S[1],B);
*)
Stream^.ReadStrV(S);
{/Cat}
Dec(Skip);
until Skip = 0;
end;
procedure TSortedCollection.Sort;
begin
if Count <= 0 then
Exit; {JO ­¥ 㤠«ïâì! ¨­ ç¥ ¯ ¤ ¥¬ ¯® Ctrl-H ¨ â.¯.}
QSort;
end;
var
P, T: Pointer;
procedure TSortedCollection.QuickSort(L, R: LongInt);
var
I, J: LongInt;
begin
repeat
I := L;
J := R;
P := At((L+R) shr 1);
repeat
while Compare(At(I), P) < 0 do
Inc(I);
while Compare(At(J), P) > 0 do
Dec(J);
if I <= J then
begin
T := At(I);
AtPut(I, At(J));
AtPut(J, T);
Inc(I);
Dec(J);
end;
until I > J;
if L < J then
QuickSort(L, J);
L := I;
until I >= R;
end { TSortedCollection.QuickSort };
procedure TSortedCollection.QSort;
begin
if Count > 0 then
QuickSort(0, Count-1);
end;
{NOT QSort}
{-DataCompBoy-}
function TDirCol.Compare;
var
a, b, c: Byte;
begin
Compare := 0;
a := 0;
for c := 1 to Length(PString(Key1)^) do
if PString(Key1)^[c] in ['/', '\'] then
Inc(a);
b := 0;
for c := 1 to Length(PString(Key2)^) do
if PString(Key2)^[c] in ['/', '\'] then
Inc(b);
if a > b then
Compare := -1
else
Compare := +1
end;
{-DataCompBoy-}
{OldCollection !!!}
end.
You can’t perform that action at this time.