Persona/tim2view
3
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

- Removed Simple Mode;

Browse Source 
- Fixed Different Bitmode View;
 - Fixed Directory Scan;
 - Other improvements.
This commit is contained in:
meffi@lab313.ru
2014-02-18 22:07:44 +00:00
parent b84a8264a2
commit 20f1dbf7ce
17 changed files with 445 additions and 11990 deletions
Download Patch File Download Diff File Expand all files Collapse all files

10011
units/NativeXml.pas
View File

File diff suppressed because it is too large Load Diff

219
units/sdDebug.pas
View File

@@ -1,219 +0,0 @@
{ unit sdDebug
universal method for debugging
Exceptions often are a hindrance, so instead use these classes
to give important info to the application or user with these
three basic classes
Besides debug methods, this unit also defines a few compatibility types:
The include file simdesign.inc defines $D5UP and after the
uses-clause these types for D5 are defined. This way, many simdesign
projects are compatible with Delphi 5.
fpc: if lazarus + freepascal is defined, Utf8String just reverts to "string".
Author: Nils Haeck M.Sc.
Original Date: 08nov2010
copyright (c) SimDesign BV (www.simdesign.nl)
}
unit sdDebug;
{$i simdesign.inc}
interface
uses
Classes;
{$ifdef D5UP}
// D5 compatibility types
const
MinsPerHour = 60;
MinsPerDay = MinsPerHour * 24;
soCurrent = soFromCurrent;
soBeginning = soFromBeginning;
soEnd = soFromEnd;
type
Utf8String = AnsiString;
TSeekOrigin = word;
PIntegerArray = ^TIntegerArray;
TIntegerArray = array of Integer;
PByte = ^Byte;
PInteger = ^Integer;
PSingle = ^Single;
PDouble = ^Double;
// TFormatSettings stub
TFormatSettings = record
end;
PWord = ^Word;
function StrToFloatDef(S: AnsiString; Default: Double; AFormatSettings: TFormatSettings): Double;
function StrToBool(S: AnsiString): Boolean;
function StrToBoolDef(S: AnsiString; Default: Boolean): Boolean;
{$endif}
// lazarus compatibility
{$ifdef fpc}
type
Utf8String = string;
{$endif fpc}
// Delphi unicode compatibility
{$ifndef UNICODE}
type
UnicodeString = WideString;
RawByteString = AnsiString;
{$endif UNICODE}
type
TsdWarnStyle = (wsInfo, wsHint, wsWarn, wsFail);
const
cWarnStyleNames: array[TsdWarnStyle] of Utf8String = ('info', 'hint', 'warn', 'fail');
type
// event with debug data
TsdDebugEvent = procedure(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String) of object;
// simple update event
TsdUpdateEvent = procedure(Sender: TObject) of object;
TDebugComponent = class(TComponent)
protected
FOnDebugOut: TsdDebugEvent;
public
procedure DoDebugOut(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String); virtual;
// Connect to OnDebugOut to get debug information in the client application
property OnDebugOut: TsdDebugEvent read FOnDebugOut write FOnDebugOut;
end;
TDebugObject = class(TObject)
protected
FOnDebugOut: TsdDebugEvent;
procedure DoDebugOut(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String); virtual;
public
property OnDebugOut: TsdDebugEvent read FOnDebugOut write FOnDebugOut;
end;
TDebugPersistent = class(TPersistent)
protected
FOwner: TDebugComponent;
procedure DoDebugOut(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String); virtual;
public
constructor CreateDebug(AOwner: TDebugComponent); virtual;
end;
{ Functions }
function sdDebugMessageToString(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String): Utf8String;
function sdClassName(AObject: TObject): Utf8String;
implementation
{$ifdef D5UP}
// D5 compatibility types
uses
SysUtils;
function StrToFloatDef(S: AnsiString; Default: Double; AFormatSettings: TFormatSettings): Double;
begin
try
Result:= StrToFloat(S);
except
Result:= Default;
end;
end;
// Only basic support
function StrToBool(S: AnsiString): Boolean;
begin
S := LowerCase(S);
if (S = 'no') or (S = '0') or (S = 'false') then
Result := False
else
if (S = 'yes') or (S = '1') or (S = 'true') then
Result:= True
else
raise EConvertError.Create('');
end;
function StrToBoolDef(S: AnsiString; Default: Boolean): Boolean;
begin
try
Result := StrToBool(S);
except
Result := Default;
end;
end;
{$endif}
{ TDebugComponent }
procedure TDebugComponent.DoDebugOut(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String);
var
AOwner: TComponent;
begin
AOwner := Self;
while AOwner is TDebugComponent do
begin
if assigned(TDebugComponent(AOwner).FOnDebugOut) then
begin
TDebugComponent(AOwner).FOnDebugOut(Sender, WarnStyle, AMessage);
exit;
end;
AOwner := AOwner.Owner;
end;
end;
{ TDebugObject }
procedure TDebugObject.DoDebugOut(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String);
begin
if assigned(FOnDebugOut) then
FOnDebugOut(Sender, WarnStyle, AMessage);
end;
{ TDebugPersistent }
constructor TDebugPersistent.CreateDebug(AOwner: TDebugComponent);
begin
inherited Create;
FOwner := AOwner;
end;
procedure TDebugPersistent.DoDebugOut(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String);
begin
if FOwner is TDebugComponent then
TDebugComponent(FOwner).DoDebugOut(Sender, WarnStyle, AMessage);
end;
{ Functions }
function sdDebugMessageToString(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String): Utf8String;
var
SenderString: Utf8String;
begin
if assigned(Sender) then
SenderString := Utf8String(Sender.ClassName)
else
SenderString := '';
Result := '[' + cWarnStyleNames[WarnStyle] + '] ' + SenderString + ': ' + AMessage;
end;
function sdClassName(AObject: TObject): Utf8String;
begin
Result := 'nil';
if assigned(AObject) then
Result := Utf8String(AObject.ClassName);
end;
end.

309
units/sdStreams.pas
View File

@@ -1,309 +0,0 @@
{ sdStreams.pas
- TsdFastMemStream with improved capacity setting
- TsdStringStream
- TsdBufferWriter
Author: Nils Haeck M.Sc.
copyright (c) 2002 - 2011 SimDesign BV (www.simdesign.nl)
}
unit sdStreams;
{$ifdef lcl}{$MODE Delphi}{$endif}
{$define simdesign.inc}
interface
uses
Classes, SysUtils, sdDebug;
type
// TsdFastMemStream deals differently with capacity compared to a normal
// TMemoryStream; it increases the capacity with the natural growing function
// (fibonacci) each time, and has an initial capacity of $1000. The initial
// capacity is configurable with the create parameter.
TsdFastMemStream = class(TStream)
private
FMemory: Pointer;
FPosition: longint;
FFib1: longint;
FCapacity: longint;
FSize: longint;
protected
procedure SetCapacity(Value: longint);
procedure SetSize(NewSize: Longint); override;
public
constructor Create(InitialCapacity: longint = $1000);
destructor Destroy; override;
procedure Clear;
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
function Seek(Offset: Longint; Origin: Word): Longint; override;
procedure LoadFromFile(AFilename: string);
procedure LoadFromStream(Stream: TStream);
procedure SaveToFile(AFilename: string);
procedure SaveToStream(Stream: TStream);
property Memory: Pointer read FMemory;
property Size: longint read FSize write SetSize;
end;
// Delphi's implementation of TStringStream is severely flawed, it does a SetLength
// on each write, which slows down everything to a crawl. This implementation over-
// comes this issue.
TsdStringStream = class(TsdFastMemStream)
public
constructor Create(const S: Utf8String);
function DataString: Utf8String;
end;
// TsdBufferWriter is a buffered stream that takes another stream (ASource)
// and writes only buffer-wise to it, and writes to the stream are first
// done to the buffer. This stream type can only support writing.
TsdBufferWriter = class(TsdFastMemStream)
private
FSource: TStream;
FChunkSize: integer;
FRawBuffer: array of byte;
FRawPosition: Integer;
protected
procedure WriteChunk(Count: integer);
public
// Create the buffered writer stream by passing the destination stream in ASource,
// this destination stream must already be initialized.
constructor Create(ASource: TStream; AChunkSize: integer);
destructor Destroy; override;
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
end;
implementation
{ TsdFastMemStream }
procedure TsdFastMemStream.Clear;
begin
SetCapacity(0);
FSize := 0;
FPosition := 0;
end;
constructor TsdFastMemStream.Create(InitialCapacity: Integer);
begin
inherited Create;
FFib1 := InitialCapacity div 2;
FCapacity := InitialCapacity;
if FFib1 < 4 then
FFib1 := 4;
if FCapacity < 4 then
FCapacity := 4;
ReallocMem(FMemory, FCapacity);
end;
destructor TsdFastMemStream.Destroy;
begin
ReallocMem(FMemory, 0);
inherited;
end;
procedure TsdFastMemStream.LoadFromFile(AFilename: string);
var
Stream: TStream;
begin
Stream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
try
LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
procedure TsdFastMemStream.LoadFromStream(Stream: TStream);
var
Count: Longint;
begin
Stream.Position := 0;
Count := Stream.Size;
SetSize(Count);
if Count <> 0 then Stream.ReadBuffer(FMemory^, Count);
end;
function TsdFastMemStream.Read(var Buffer; Count: Integer): Longint;
begin
if (FPosition >= 0) and (Count >= 0) then
begin
Result := FSize - FPosition;
if Result > 0 then
begin
if Result > Count then
Result := Count;
Move(Pointer(Longint(FMemory) + FPosition)^, Buffer, Result);
Inc(FPosition, Result);
Exit;
end;
end;
Result := 0;
end;
procedure TsdFastMemStream.SaveToFile(AFilename: string);
var
Stream: TStream;
begin
Stream := TFileStream.Create(AFileName, fmCreate);
try
SaveToStream(Stream);
finally
Stream.Free;
end;
end;
procedure TsdFastMemStream.SaveToStream(Stream: TStream);
begin
if FSize <> 0 then Stream.WriteBuffer(FMemory^, FSize);
end;
function TsdFastMemStream.Seek(Offset: Integer; Origin: Word): Longint;
begin
case Origin of
soFromBeginning: FPosition := Offset;
soFromCurrent: Inc(FPosition, Offset);
soFromEnd: FPosition := FSize + Offset;
end;
Result := FPosition;
end;
procedure TsdFastMemStream.SetCapacity(Value: longint);
// Fibonacci 0,1,1,2,3,5,8,... FCapacity is Fib2.
// Fibonacci is a natural growing function where
// 0 + 1 = 1; 1 + 1 = 2; 1 + 2 = 3; 2 + 3 = 5; etc
var
Fib3: longint;
begin
while FCapacity < Value do
begin
Fib3 := FFib1 + FCapacity;
FFib1 := FCapacity;
FCapacity := Fib3;
end;
ReallocMem(FMemory, FCapacity);
end;
procedure TsdFastMemStream.SetSize(NewSize: longint);
var
OldPosition: Longint;
begin
OldPosition := FPosition;
SetCapacity(NewSize);
FSize := NewSize;
if OldPosition > NewSize then
Seek(0, soFromEnd);
end;
function TsdFastMemStream.Write(const Buffer; Count: Integer): Longint;
var
NewPos: Longint;
begin
if (FPosition >= 0) and (Count >= 0) then
begin
NewPos := FPosition + Count;
if NewPos > 0 then
begin
if NewPos > FSize then
begin
if NewPos > FCapacity then
SetCapacity(NewPos);
FSize := NewPos;
end;
System.Move(Buffer, Pointer(Longint(FMemory) + FPosition)^, Count);
FPosition := NewPos;
Result := Count;
Exit;
end;
end;
Result := 0;
end;
{ TsdStringStream }
constructor TsdStringStream.Create(const S: Utf8String);
begin
inherited Create;
SetSize(length(S));
if Size > 0 then
begin
Write(S[1], Size);
Position := 0;
end;
end;
function TsdStringStream.DataString: Utf8String;
begin
SetLength(Result, Size);
if Size > 0 then
begin
Position := 0;
Read(Result[1], length(Result));
end;
end;
{ TsdBufferWriter }
constructor TsdBufferWriter.Create(ASource: TStream; AChunkSize: integer);
begin
inherited Create;
FSource := ASource;
FChunkSize := AChunkSize;
SetLength(FRawBuffer, FChunkSize);
end;
destructor TsdBufferWriter.Destroy;
begin
// write the last chunk, if any
WriteChunk(FRawPosition);
// free the rawbuffer
SetLength(FRawBuffer, 0);
inherited;
end;
function TsdBufferWriter.Read(var Buffer; Count: Integer): Longint;
begin
// not implemented
raise Exception.Create('not implemented');
end;
function TsdBufferWriter.Write(const Buffer; Count: Integer): Longint;
var
Idx, Siz: integer;
begin
// index in the source buffer
Idx := 0;
// remaining size
Siz := Count;
// surplus
while FRawPosition + Siz >= FChunkSize do
begin
Move(TByteArray(Buffer)[Idx], FRawBuffer[FRawPosition], FChunkSize - FRawPosition);
WriteChunk(FChunkSize);
dec(Siz, FChunkSize - FRawPosition);
inc(Idx, FChunkSize - FRawPosition);
FRawPosition := 0;
end;
// copy the raw buffer
Move(TByteArray(Buffer)[Idx], FRawBuffer[FRawPosition], Siz);
inc(FRawPosition, Siz);
Result := Count;
end;
procedure TsdBufferWriter.WriteChunk(Count: integer);
begin
if Count > 0 then
begin
FSource.WriteBuffer(FRawBuffer[0], Count);
end;
end;
end.

765
units/sdStringTable.pas
View File

@@ -1,765 +0,0 @@
{ unit sdStringTable
An optimized table of *unique* strings, using two separate sorted indices:
- by (string) ID
- by sdCompareRefString method
The sdCompareRefString method does not use common alphabetical compare, but
rather a comparison from first character, then last character, then 2nd,
then before-last, etc. until all characters are compared, or a mismatch is
found.
Since many (programmer) strings have numbers at the end of the string,
(e.g. "MyNewNode1", "MyNewNode2", etc), the comparison terminates earlier than
with a common alphabetical compare.
sdStringTable is used by NativeXml but can also be used independently in
your projects.
Author: Nils Haeck M.Sc. (n.haeck@simdesign.nl)
Original Date: 28 May 2007
Modified:
05jan2011: enhancement, no longer uses stringrec
17jun2011: changed TStringTable ancestor from TDebugPersistent to TDebugComponent
24jun2011: "find" fix
18jul2011: renamed TsdStringTable to TsdSymbolTable and added TsdSymbolStyle
It is NOT allowed under ANY circumstances to publish or copy this code
without accepting the license conditions in accompanying LICENSE.txt
first!
This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF
ANY KIND, either express or implied.
Please visit http://www.simdesign.nl/xml.html for more information.
Copyright (c) 2007 - 2011 Simdesign BV
}
unit sdStringTable;
{$ifdef lcl}{$MODE Delphi}{$endif}
interface
uses
Classes, SysUtils, Contnrs, sdDebug;
// symbol styles (cardinal)
// Default symbol style is ssUnknown, but highlevel code can
// distinguish between symbol styles. TsdSymbolTable just stores
// the symbol as counted Utf8String.
const
ssUnknown = 0; // data not determined yet
ssString = 1; // data is a string
ssBase64Binary = 2; // data is binary and will be handled by Base64 funcs
ssHexBinary = 3; // data is binary and will be handled by BinHex funcs
ssBoolean = 4; // boolean (stored in a byte, just 0 and 1 of cardinal)
ssCardinal = 5; // cardinal (1..N bytes, see TBinaryXml.ReadCardinal)
ssInteger = 6; // integer (1..N bytes)
ssDecimal = 7; // decimal value (see TNativeXml.EncodeDecimalSymbol)
ssDate = 8; // date (see TNativeXml.EncodeDateSymbol)
ssTime = 9; // time (see TNativeXml.EncodeTimeSymbol)
ssDateTime = 10; // datetime (see TNativeXml.EncodeDateTimeSymbol)
// These were the default symbol styles as used by NativeXml. Other units may
// define more symbols after the last default symbol
type
// A symbol table, holding a collection of unique strings, sorted in 2 ways
// for fast access. Strings can be added with AddString or AddStringRec.
// When a string is added or updated, an ID is returned which the application
// can use to retrieve the string, using GetString.
TsdSymbolTable = class(TDebugComponent)
private
FByID: TObjectList;
FBySymbol: TObjectList;
FPluralSymbolCount: integer;
function GetSymbolCount: integer;
protected
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
// Clear the string table
procedure Clear;
// Add a potentially new string S to the table, the function
// returns its string ID.
function AddString(const S: Utf8String): integer;
// retrieve the string based on its string ID. The string ID is only unique
// within this string table, so do not use IDs from other tables.
function GetString(ID: integer): Utf8String;
// total number of symbols in the table
property SymbolCount: integer read GetSymbolCount;
// plural symbols in the table. plural symbols are symbols that have
// a frequency > 1. ie the symbol is found more than once in the app.
// PluralCount is only valid after method SortByFrequency.
property PluralSymbolCount: integer read FPluralSymbolCount;
procedure LoadFromFile(const AFileName: string);
procedure LoadFromStream(S: TStream);
function LoadSymbol(S: TStream): Cardinal;
procedure SaveToFile(const AFileName: string);
procedure SaveToStream(S: TStream; ACount: integer);
procedure SaveSymbol(S: TStream; ASymbolID: Cardinal);
procedure ClearFrequency;
procedure IncrementFrequency(ID: integer);
procedure SortByFrequency(var ANewIDs: array of Cardinal);
end;
{utility functions}
// compare two bytes
function sdCompareByte(Byte1, Byte2: byte): integer;
// compare two integers
function sdCompareInteger(Int1, Int2: integer): integer;
// unicode UTF8 <> UTF16LE coversion functions
function sdUtf16ToUtf8Mem(Src: Pword; Dst: Pbyte; Count: integer): integer;
function sdUtf8ToUtf16Mem(var Src: Pbyte; Dst: Pword; Count: integer): integer;
// stream methods
function sdStreamReadCardinal(S: TStream): Cardinal;
function sdStreamReadString(S: TStream; ACharCount: Cardinal): Utf8String;
procedure sdStreamWriteCardinal(S: TStream; ACardinal: Cardinal);
procedure sdStreamWriteString(S: TStream; const AString: Utf8String);
implementation
type
// A symbol item used in symbol lists (do not use directly)
TsdSymbol = class
private
FID: integer;
FFreq: Cardinal;
FSymbolStyle: Cardinal;
FFirst: Pbyte;
FCharCount: integer;
public
destructor Destroy; override;
function AsString: Utf8String;
property SymbolStyle: Cardinal read FSymbolStyle;
property CharCount: integer read FCharCount;
end;
// A list of symbols (do not use directly)
TsdSymbolList = class(TObjectList)
private
function GetItems(Index: integer): TsdSymbol;
protected
// Assumes list is sorted by refstring
function Find(ASymbol: TsdSymbol; var Index: integer): boolean;
public
property Items[Index: integer]: TsdSymbol read GetItems; default;
end;
// compare two symbols. This is NOT an alphabetic compare. symbols are first
// compared by length, then by first byte, then last byte then second, then
// N-1, until all bytes are compared.
function sdCompareSymbol(Symbol1, Symbol2: TsdSymbol): integer;
var
CharCount: integer;
First1, First2, Last1, Last2: Pbyte;
IsEqual: boolean;
begin
// Compare string length first
Result := sdCompareInteger(Symbol1.CharCount, Symbol2.CharCount);
if Result <> 0 then
exit;
// Compare FFirst
Result := sdCompareByte(Symbol1.FFirst^, Symbol2.FFirst^);
if Result <> 0 then
exit;
// CharCount of RS1 (and RS2, since they are equal)
CharCount := Symbol1.CharCount;
// Setup First & Last pointers
First1 := Symbol1.FFirst;
First2 := Symbol2.FFirst;
// compare memory (boolean op). CompareMem might have optimized code depending
// on memory manager (ASM, MMX, SSE etc) to binary compare the block.
// Since sdCompareRefString may be used to compare relatively large blocks of
// text, which are often exact copies, using CompareMem before special comparison
// is warrented.
IsEqual := CompareMem(First1, First2, CharCount);
if IsEqual then
begin
Result := 0;
exit;
end;
// finally the special conparison: Compare each time last ptrs then first ptrs,
// until they meet in the middle
Last1 := First1;
inc(Last1, CharCount);
Last2 := First2;
inc(Last2, CharCount);
repeat
dec(Last1);
dec(Last2);
if First1 = Last1 then
exit;
Result := sdCompareByte(Last1^, Last2^);
if Result <> 0 then
exit;
inc(First1);
inc(First2);
if First1 = Last1 then
exit;
Result := sdCompareByte(First1^, First2^);
if Result <> 0 then
exit;
until False;
end;
{ TsdSymbol }
function TsdSymbol.AsString: Utf8String;
begin
SetString(Result, PAnsiChar(FFirst), FCharCount);
end;
destructor TsdSymbol.Destroy;
begin
FreeMem(FFirst);
inherited;
end;
{ TsdSymbolList }
function TsdSymbolList.GetItems(Index: integer): TsdSymbol;
begin
Result := Get(Index);
end;
function TsdSymbolList.Find(ASymbol: TsdSymbol; var Index: integer): boolean;
var
AMin, AMax: integer;
begin
Result := False;
// Find position - binary method
AMin := 0;
AMax := Count;
while AMin < AMax do
begin
Index := (AMin + AMax) div 2;
case sdCompareSymbol(Items[Index], ASymbol) of
-1: AMin := Index + 1;
0: begin
Result := True;
exit;
end;
1: AMax := Index;
end;
end;
Index := AMin;
end;
{ TsdSymbolTable }
function TsdSymbolTable.AddString(const S: Utf8String): integer;
var
Found: boolean;
L, BySymbolIndex: integer;
ASymbol, Item: TsdSymbol;
begin
Result := 0;
L := length(S);
// zero-length string
if L = 0 then
exit;
ASymbol := TsdSymbol.Create;
try
ASymbol.FFirst := PByte(@S[1]);
ASymbol.FCharCount := L;
// Try to find the new string
Found := TsdSymbolList(FBySymbol).Find(ASymbol, BySymbolIndex);
if Found then
begin
// yes it is found
Item := TsdSymbol(FBySymbol[BySymbolIndex]);
Result := Item.FID;
exit;
end;
// Not found.. must make new item
Item := TsdSymbol.Create;
Item.FCharCount := ASymbol.FCharCount;
// reallocate memory and copy the string data
ReallocMem(Item.FFirst, Item.FCharCount);
Move(S[1], Item.FFirst^, Item.FCharCount);
// add to the ByID objectlist
FByID.Add(Item);
Item.FID := FByID.Count;
Result := Item.FID;
// insert into the ByRS list
FBySymbol.Insert(BySymbolIndex, Item);
finally
// this ensures we do not deallocate the memory that may be in use elsewhere
ASymbol.FFirst := nil;
ASymbol.Free;
end;
end;
procedure TsdSymbolTable.Clear;
begin
FByID.Clear;
FBySymbol.Clear;
end;
procedure TsdSymbolTable.ClearFrequency;
var
i: integer;
begin
for i := 0 to FByID.Count - 1 do
TsdSymbol(FByID[i]).FFreq := 0;
end;
constructor TsdSymbolTable.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FByID := TObjectList.Create(True);
FBySymbol := TsdSymbolList.Create(False);
end;
destructor TsdSymbolTable.Destroy;
begin
FreeAndNil(FBySymbol);
FreeAndNil(FByID);
inherited;
end;
function TsdSymbolTable.GetSymbolCount: integer;
begin
Result := FByID.Count;
end;
function TsdSymbolTable.GetString(ID: integer): Utf8String;
begin
// Find the ID
// zero string
if ID <= 0 then
begin
Result := '';
exit;
end;
// out of bounds?
if ID > FByID.Count then
begin
// output warning
DoDebugOut(Self, wsWarn, 'string ID not found');
Result := '';
end;
Result := TsdSymbol(FByID[ID - 1]).AsString;
end;
procedure TsdSymbolTable.IncrementFrequency(ID: integer);
var
RS: TsdSymbol;
begin
RS := TsdSymbol(FByID[ID - 1]);
inc(RS.FFreq);
end;
procedure TsdSymbolTable.LoadFromFile(const AFileName: string);
var
S: TMemoryStream;
begin
S := TMemoryStream.Create;
try
S.LoadFromFile(AFileName);
LoadFromStream(S);
finally
S.Free;
end;
end;
procedure TsdSymbolTable.LoadFromStream(S: TStream);
var
i: integer;
TableCount: Cardinal;
begin
Clear;
// DoDebugOut(Self, wsInfo, format('stream position: %d', [S.Position]));
// table count
TableCount := sdStreamReadCardinal(S);
if TableCount = 0 then
exit;
for i := 0 to TableCount - 1 do
begin
LoadSymbol(S);
end;
end;
function TsdSymbolTable.LoadSymbol(S: TStream): Cardinal;
var
Symbol: TsdSymbol;
BySymbolIndex: integer;
Found: boolean;
begin
Symbol := TsdSymbol.Create;
// For now, we just use ssString uniquely as symbol style,.
// In updates, different symbol styles can be added.
Symbol.FSymbolStyle := sdStreamReadCardinal(S);
Symbol.FCharCount := sdStreamReadCardinal(S);
if Symbol.FCharCount > 0 then
begin
// reallocate memory and copy the string data
ReallocMem(Symbol.FFirst, Symbol.FCharCount);
S.Read(Symbol.FFirst^, Symbol.FCharCount);
end;
// add to the ByID objectlist
FByID.Add(Symbol);
Symbol.FID := FByID.Count;
Result := Symbol.FID;
// find the symbol
Found := TsdSymbolList(FBySymbol).Find(Symbol, BySymbolIndex);
if Found then
begin
DoDebugOut(Self, wsFail, 'duplicate symbol!');
exit;
end;
// insert into the ByRS list
FBySymbol.Insert(BySymbolIndex, Symbol);
end;
procedure TsdSymbolTable.SaveToFile(const AFileName: string);
var
S: TMemoryStream;
begin
S := TMemoryStream.Create;
try
SaveToStream(S, SymbolCount);
S.SaveToFile(AFileName);
finally
S.Free;
end;
end;
procedure TsdSymbolTable.SaveToStream(S: TStream; ACount: integer);
var
i: integer;
begin
// write (part of the) symbol table
sdStreamWriteCardinal(S, ACount);
for i := 0 to ACount - 1 do
begin
SaveSymbol(S, i + 1);
end;
end;
procedure TsdSymbolTable.SaveSymbol(S: TStream; ASymbolID: Cardinal);
var
RS: TsdSymbol;
StringVal: Utf8String;
CharCount: Cardinal;
begin
if ASymbolID <= 0 then
DoDebugOut(Self, wsFail, 'symbol ID <= 0');
RS := TsdSymbol(FByID[ASymbolID - 1]);
// For now, we just use ssString uniquely as symbol style.
// In updates, different symbol styles can be added.
sdStreamWriteCardinal(S, RS.SymbolStyle);
StringVal := RS.AsString;
CharCount := length(StringVal);
sdStreamWriteCardinal(S, CharCount);
sdStreamWriteString(S, StringVal);
end;
procedure TsdSymbolTable.SortByFrequency(var ANewIDs: array of Cardinal);
// local
function CompareFreq(Pos1, Pos2: integer): integer;
var
RS1, RS2: TsdSymbol;
begin
RS1 := TsdSymbol(FByID[Pos1]);
RS2 := TsdSymbol(FByID[Pos2]);
if RS1.FFreq > RS2.FFreq then
Result := -1
else
if RS1.FFreq < RS2.FFreq then
Result := 1
else
Result := 0;
end;
// local
procedure QuickSort(iLo, iHi: Integer);
var
Lo, Hi, Mid: longint;
begin
Lo := iLo;
Hi := iHi;
Mid:= (Lo + Hi) div 2;
repeat
while CompareFreq(Lo, Mid) < 0 do
Inc(Lo);
while CompareFreq(Hi, Mid) > 0 do
Dec(Hi);
if Lo <= Hi then
begin
// Swap pointers;
FByID.Exchange(Lo, Hi);
if Mid = Lo then
Mid := Hi
else
if Mid = Hi then
Mid := Lo;
Inc(Lo);
Dec(Hi);
end;
until Lo > Hi;
if Hi > iLo then
QuickSort(iLo, Hi);
if Lo < iHi then
QuickSort(Lo, iHi);
end;
// main
var
i: integer;
begin
// sort by frequency
QuickSort(0, FByID.Count - 1);
// plural count
FPluralSymbolCount := 0;
i := 0;
while i < FByID.Count do
begin
if TsdSymbol(FByID[i]).FFreq >= 2 then
inc(FPluralSymbolCount)
else
break;
inc(i);
end;
// tell app about new ID
for i := 0 to FByID.Count - 1 do
begin
ANewIDs[TsdSymbol(FByID[i]).FID] := i + 1;
end;
// then rename IDs
for i := 0 to FByID.Count - 1 do
begin
TsdSymbol(FByID[i]).FID := i + 1;
end;
end;
{utility functions}
function sdCompareByte(Byte1, Byte2: byte): integer;
begin
if Byte1 < Byte2 then
Result := -1
else
if Byte1 > Byte2 then
Result := 1
else
Result := 0;
end;
function sdCompareInteger(Int1, Int2: integer): integer;
begin
if Int1 < Int2 then
Result := -1
else
if Int1 > Int2 then
Result := 1
else
Result := 0;
end;
function sdUtf16ToUtf8Mem(Src: Pword; Dst: Pbyte; Count: integer): integer;
// Convert an Unicode (UTF16 LE) memory block to UTF8. This routine will process
// Count wide characters (2 bytes size) to Count UTF8 characters (1-3 bytes).
// Therefore, the block at Dst must be at least 1.5 the size of the source block.
// The function returns the number of *bytes* written.
var
W: word;
DStart: Pbyte;
begin
DStart := Dst;
while Count > 0 do
begin
W := Src^;
inc(Src);
if W <= $7F then
begin
Dst^ := byte(W);
inc(Dst);
end else
begin
if W > $7FF then
begin
Dst^ := byte($E0 or (W shr 12));
inc(Dst);
Dst^ := byte($80 or ((W shr 6) and $3F));
inc(Dst);
Dst^ := byte($80 or (W and $3F));
inc(Dst);
end else
begin // $7F < W <= $7FF
Dst^ := byte($C0 or (W shr 6));
inc(Dst);
Dst^ := byte($80 or (W and $3F));
inc(Dst);
end;
end;
dec(Count);
end;
Result := integer(Dst) - integer(DStart);
end;
function sdUtf8ToUtf16Mem(var Src: Pbyte; Dst: Pword; Count: integer): integer;
// Convert an UTF8 memory block to Unicode (UTF16 LE). This routine will process
// Count *bytes* of UTF8 (each character 1-3 bytes) into UTF16 (each char 2 bytes).
// Therefore, the block at Dst must be at least 2 times the size of Count, since
// many UTF8 characters consist of just one byte, and are mapped to 2 bytes. The
// function returns the number of *wide chars* written. Note that the Src block must
// have an exact number of UTF8 characters in it, if Count doesn't match then
// the last character will be converted anyway (going past the block boundary!)
var
W: word;
C: byte;
DStart: Pword;
SClose: Pbyte;
begin
DStart := Dst;
SClose := Src;
inc(SClose, Count);
while integer(Src) < integer(SClose) do
begin
// 1st byte
W := Src^;
inc(Src);
if W and $80 <> 0 then
begin
W := W and $3F;
if W and $20 <> 0 then
begin
// 2nd byte
C := Src^;
inc(Src);
if C and $C0 <> $80 then
// malformed trail byte or out of range char
Continue;
W := (W shl 6) or (C and $3F);
end;
// 2nd or 3rd byte
C := Src^;
inc(Src);
if C and $C0 <> $80 then
// malformed trail byte
Continue;
Dst^ := (W shl 6) or (C and $3F);
inc(Dst);
end else
begin
Dst^ := W;
inc(Dst);
end;
end;
Result := (integer(Dst) - integer(DStart)) div 2;
end;
{ stream methods }
function sdStreamReadCardinal(S: TStream): Cardinal;
var
C: byte;
Bits: integer;
begin
Result := 0;
Bits := 0;
repeat
S.Read(C, 1);
if C > 0 then
begin
inc(Result, (C and $7F) shl Bits);
inc(Bits, 7)
end;
until(C and $80) = 0;
end;
function sdStreamReadString(S: TStream; ACharCount: Cardinal): Utf8String;
begin
SetLength(Result, ACharCount);
if ACharCount = 0 then
exit;
S.Read(Result[1], ACharCount);
end;
procedure sdStreamWriteCardinal(S: TStream; ACardinal: Cardinal);
var
C: byte;
begin
repeat
if ACardinal <= $7F then
begin
C := ACardinal;
S.Write(C, 1);
exit;
end else
C := (ACardinal and $7F) or $80;
S.Write(C, 1);
ACardinal := ACardinal shr 7;
until ACardinal = 0;
end;
procedure sdStreamWriteString(S: TStream; const AString: Utf8String);
var
L: integer;
begin
L := Length(AString);
if L > 0 then
begin
S.Write(AString[1], L);
end;
end;
end.

95
units/simdesign.inc
View File

@@ -1,95 +0,0 @@
{ simdesign.inc
include file for many simdesign projects
default path: \simlib\general
Author: Nils Haeck M.Sc.
Copyright (c) 2007 - 2011 Simdesign B.V.
}
// unicode avoid implicit string cast warning
{$ifdef UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$endif UNICODE}
// Delphi and FPC versions
// Freepascal
{$ifdef FPC}
{$MODE DELPHI}
{$define D7UP}
{$endif FPC}
// Delphi 5
{$ifdef VER130}
{$define D5UP}
{$endif}
//Delphi 6
{$ifdef VER140}
{$define D5UP}
{$endif}
//Delphi 7
{$ifdef VER150}
{$define D7UP}
{$endif}
//Delphi 8
{$ifdef VER160}
{$define D7UP}
{$endif}
// Delphi 2005 / 9
{$ifdef VER170}
{$define D7UP}
{$endif}
// Delphi 2006 / 10
{$ifdef VER180}
{$define D7UP}
// D10 publishes OnMouseEnter / OnMouseLeave
{$define D10UP}
{$endif}
// Delphi 2007 Rad studio / 11?
{$ifdef VER185}
{$define D7UP}
{$define D10UP}
{$endif}
// Delphi 2007 - NET / 11?
{$ifdef VER190}
{$define D7UP}
{$define D10UP}
{$endif}
// Delphi 2009 / 12
// first UNICODE version, so then directive UNICODE is defined, no need for directive D12UP
{$ifdef VER200}
{$define D7UP}
{$define D10UP}
{$endif}
// Delphi 2010 / 14?
{$ifdef VER210}
{$define D7UP}
{$define D10UP}
{$endif}
// Delphi XE / 15
{$ifdef VER220}
{$define D7UP}
{$define D10UP}
{$define D15UP}
{$endif}
// Delphi XE2 / 16
{$ifdef VER230}
{$define D7UP}
{$define D10UP}
{$define D15UP}
{$endif}

16
units/uCDIMAGE.pas
View File

@@ -32,10 +32,10 @@ type
PCDSector = ^TCDSector;
function GetImageScan(const FileName: string): Boolean;
function ReplaceTimInFile(const FileName, TimToInsert: string; InsertTo: DWORD;
function ReplaceTimInFile(const FileName, TimToInsert: string; InsertTo: Integer;
ImageScan: Boolean): Boolean;
procedure ReplaceTimInFileFromMemory(const FileName: string; TIM: PTIM;
InsertTo: DWORD; ImageScan: Boolean);
InsertTo: Integer; ImageScan: Boolean);
implementation
@@ -87,16 +87,16 @@ begin
end;
procedure ReplaceTimInFileFromMemory(const FileName: string; TIM: PTIM;
InsertTo: DWORD; ImageScan: Boolean);
InsertTo: Integer; ImageScan: Boolean);
type
TSecAddrAndMode = array [0 .. cSectorAddressSize + cSectorModeSize - 1] of byte;
var
sImageStream: TFileStream;
TimOffsetInSector, FirstPartSize, LastPartSize: DWORD;
TimSectorNumber, TimStartSectorPos: DWORD;
TimOffsetInSector, FirstPartSize, LastPartSize: Integer;
TimSectorNumber, TimStartSectorPos: Integer;
Sector: TCDSector;
ecc: DWORD;
P, TIM_FULL_SECTORS: DWORD;
P, TIM_FULL_SECTORS: Integer;
SecAddrAndMode: TSecAddrAndMode;
begin
sImageStream := TFileStream.Create(FileName, fmOpenReadWrite or
@@ -202,11 +202,11 @@ begin
sImageStream.free;
end;
function ReplaceTimInFile(const FileName, TimToInsert: string; InsertTo: DWORD;
function ReplaceTimInFile(const FileName, TimToInsert: string; InsertTo: Integer;
ImageScan: Boolean): Boolean;
var
SIZE, P: DWORD;
SIZE, P: Integer;
TIM: PTIM;
begin
Result := False;

36
units/uCommon.pas
View File

@@ -3,40 +3,25 @@ unit uCommon;
interface
uses
NativeXML, Windows;
Windows;
const
cProgramName = 'Tim2View by [Lab 313]';
cProgramVersion = '2.0';
cMaxFileSize = $2EAEED80;
cExtractedTimsDir = 'TIMS';
cResRootName = 'TVSCANRESULT';
cResInfoNode = 'INFO';
cResAttrFile = 'FILENAME';
cResAttrVersion = 'VERSION';
cResAttrImageFile = 'CDIMAGE';
cResAttrTimsCount = 'TIMSCOUNT';
cResTimsNode = 'TIMS';
cResTimNode = 'TIM';
cResTimAttrPos = 'POSITION';
cResTimAttrSize = 'SIZE';
cResTimAttrWidth = 'WIDTH';
cResTimAttrHeight = 'HEIGHT';
cResTimAttrBitMode = 'BITMODE';
cResTimAttrGood = 'GOODTIM';
cMaxFileSize = $2EAEED80;
cAutoExtractionTimFormat = '%s_%.6d_%.2db' + '.tim';
cCLUTGridColsCount = 32;
sStatusBarScanningFile = 'Scanning File...';
sStatusBarTimsExtracting = 'TIM''s Extracting...';
sStatusBarTimsExtracting = 'TIMs Extracting...';
sStatusBarTimsExtracted = 'Exctracted Successfully!';
sStatusBarParsingResult = 'Parsing Result...';
sScanResultGood = 'Scan completed!';
sSelectDirCaption = 'Please, select directory for scan...';
sThisTimHasNoCLUT = 'This TIM has no CLUT';
type
PNativeXML = ^TNativeXML;
type
TBytesArray = array [0 .. cMaxFileSize - 1] of byte;
PBytesArray = ^TBytesArray;
@@ -48,11 +33,12 @@ function CheckFileExists(const FileName: string): boolean;
function ExtractFileNameWOext(const Path: string): string;
procedure Text2Clipboard(const S: string);
function Min(A, B: Integer): Integer;
function Max(A, B: Integer): Integer;
implementation
uses
uCDIMAGE, System.SysUtils, System.Classes, Clipbrd;
System.SysUtils, Clipbrd;
function Min(A, B: Integer): Integer;
begin
@@ -62,6 +48,14 @@ begin
Result := B;
end;
function Max(A, B: Integer): Integer;
begin
if A >= B then
Result := A
else
Result := B;
end;
procedure Text2Clipboard(const S: string);
begin
Clipboard.AsText := S;

4
units/uDrawTIM.pas
View File

@@ -53,7 +53,7 @@ function PrepareIMAGE(TIM: PTIM): PIMAGE_INDEXES;
var
I, OFFSET: Integer;
RW: Word;
P24: DWORD;
P24: Integer;
begin
New(Result);
OFFSET := cTIMHeadSize + GetTIMCLUTSize(TIM) + cIMAGEHeadSize;
@@ -104,7 +104,7 @@ var
X, Y, INDEX, IMAGE_DATA_POS: Integer;
R, G, B, STP, ALPHA: Byte;
COLOR: TCLUT_COLOR;
CL: DWORD;
CL: Integer;
Transparent, SemiTransparent: boolean;
begin
RW := GetTimRealWidth(TIM);

82
units/uMain.dfm
View File

@@ -1,4 +1,4 @@
object frmMainT2V: TfrmMainT2V
object frmMain: TfrmMain
Left = 0
Top = 0
Width = 754
@@ -44,6 +44,7 @@ object frmMainT2V: TfrmMainT2V
Width = 504
Height = 28
Align = alRight
Anchors = [akLeft, akTop, akRight, akBottom]
Smooth = True
TabOrder = 1
end
@@ -69,6 +70,7 @@ object frmMainT2V: TfrmMainT2V
AutoCloseUp = True
Style = csDropDownList
DropDownCount = 30
Enabled = False
TabOrder = 0
OnChange = cbbFilesChange
end
@@ -127,7 +129,7 @@ object frmMainT2V: TfrmMainT2V
ViewStyle = vsReport
OnClick = lvListClick
OnData = lvListData
OnKeyDown = lvListKeyDown
OnSelectItem = lvListSelectItem
end
end
object pnlImage: TPanel
@@ -149,21 +151,23 @@ object frmMainT2V: TfrmMainT2V
ResizeStyle = rsUpdate
ExplicitTop = 274
end
object imgTIM: TImage
Left = 1
Top = 4
Width = 500
Height = 296
object pbTim: TImage
AlignWithMargins = True
Left = 4
Top = 7
Width = 494
Height = 290
Align = alClient
Center = True
IncrementalDisplay = True
Proportional = True
ExplicitLeft = 152
ExplicitTop = 112
Transparent = True
ExplicitLeft = 168
ExplicitTop = 80
ExplicitWidth = 105
ExplicitHeight = 105
end
object grdCurrCLUT: TDrawGrid
object grdCurrClut: TDrawGrid
Left = 1
Top = 330
Width = 500
@@ -181,8 +185,8 @@ object frmMainT2V: TfrmMainT2V
ParentDoubleBuffered = False
ScrollBars = ssNone
TabOrder = 0
OnDblClick = grdCurrCLUTDblClick
OnDrawCell = grdCurrCLUTDrawCell
OnDblClick = grdCurrClutDblClick
OnDrawCell = grdCurrClutDrawCell
end
object pnlImageOptions: TPanel
Left = 1
@@ -216,7 +220,7 @@ object frmMainT2V: TfrmMainT2V
ItemIndex = 0
TabOrder = 1
Text = 'Full transparence'
OnClick = cbbTransparenceModeClick
OnChange = cbbTransparenceModeChange
Items.Strings = (
'Full transparence'
'Black Transparence'
@@ -241,14 +245,16 @@ object frmMainT2V: TfrmMainT2V
'8 BPP'
'16 BPP'
'24 BPP')
ExplicitTop = 3
end
object chkStretch: TCheckBox
Left = 404
Top = 1
Width = 97
Height = 28
AlignWithMargins = True
Left = 407
Top = 4
Width = 89
Height = 22
Action = actStretch
Align = alLeft
Align = alClient
TabOrder = 3
end
end
@@ -306,33 +312,6 @@ object frmMainT2V: TfrmMainT2V
end
object mnConfig: TMenuItem
Caption = '&Options'
object mnAutoExtract: TMenuItem
AutoCheck = True
Caption = '&Auto Extraction'
end
object Stretch1: TMenuItem
Action = actStretch
AutoCheck = True
end
object mnViewMode: TMenuItem
Caption = '&View Mode'
object mnSimpleMode: TMenuItem
AutoCheck = True
Caption = '&Simple Mode'
RadioItem = True
OnClick = mnSimpleModeClick
end
object mnAdvancedMode: TMenuItem
AutoCheck = True
Caption = '&Advanced Mode'
Checked = True
RadioItem = True
OnClick = mnAdvancedModeClick
end
end
object N5: TMenuItem
Caption = '-'
end
object mnAssociate: TMenuItem
Action = actAssocTims
end
@@ -427,7 +406,6 @@ object frmMainT2V: TfrmMainT2V
end
object actAbout: TAction
Caption = 'About...'
ShortCut = 112
OnExecute = actAboutExecute
end
object actStretch: TAction
@@ -444,10 +422,22 @@ object frmMainT2V: TfrmMainT2V
Caption = 'Open TIMs with T2V'
OnExecute = actAssocTimsExecute
end
object actExtractList: TAction
Caption = 'Extract TIMs'
Enabled = False
ShortCut = 112
OnExecute = actExtractListExecute
end
end
object pmList: TPopupMenu
Left = 640
Top = 502
object ExtractTIMs1: TMenuItem
Action = actExtractList
end
object N6: TMenuItem
Caption = '-'
end
object ExtractTIM1: TMenuItem
Action = actExtractTim
end

612
units/uMain.pas
View File

File diff suppressed because it is too large Load Diff

75
units/uScanResult.pas Normal file
View File

@@ -0,0 +1,75 @@
unit uScanResult;
interface
type
TScanTim = record
Position: Integer;
Size: Integer;
Width: Integer;
Height: Integer;
BitMode: Byte;
Good: Boolean;
end;
type
TScanResult = class(TObject)
private
pScanFile: string;
pIsImage: Boolean;
pCount: Integer;
pTims: array of TScanTim;
procedure fSetCount(Value: Integer);
function fGetTim(Index: Integer): TScanTim;
procedure fSetTim(Index: Integer; Value: TScanTim);
public
constructor Create;
destructor Destroy; override;
property ScanFile: string read pScanFile write pScanFile;
property IsImage: Boolean read pIsImage write pIsImage;
property Count: Integer read pCount write fSetCount;
property ScanTim[index: Integer]: TScanTim read fGetTim write fSetTim;
end;
implementation
{ TScanResult }
constructor TScanResult.Create;
begin
inherited;
pScanFile := '';
pIsImage := False;
pCount := 0;
pTims := nil;
end;
destructor TScanResult.Destroy;
begin
inherited;
end;
function TScanResult.fGetTim(Index: Integer): TScanTim;
begin
Result := pTims[Index];
end;
procedure TScanResult.fSetCount(Value: Integer);
begin
pCount := Value;
SetLength(pTims, Value);
end;
procedure TScanResult.fSetTim(Index: Integer; Value: TScanTim);
begin
pTims[Index] := Value;
end;
end.

106
units/uScanThread.pas
View File

@@ -3,35 +3,33 @@ unit uScanThread;
interface
uses
Classes, Windows, uCommon, uTIM;
Classes, Windows, uCommon, uTIM, uScanResult;
type
PScanThread = ^TScanThread;
TScanThread = class(Classes.TThread)
private
{ Private declarations }
pScanFile: string;
pIsImage: boolean;
pScanResult: TScanResult;
pTims: Integer;
pFileToScan: string;
pImageScan: boolean;
pResult: PNativeXml;
pFileSize: DWORD;
pFilePos: DWORD;
pFileSize: Integer;
pFilePos: Integer;
pStatusText: string;
pClearBufferPosition: DWORD;
pClearBufferSize: DWORD;
pSectorBufferSize: DWORD;
pClearBufferPosition: Integer;
pClearBufferSize: Integer;
pSectorBufferSize: Integer;
pSrcFileStream: TFileStream;
pStopScan: boolean;
procedure SetStatusText;
procedure StartScan;
procedure UpdateProgressBar;
procedure AddResult(TIM: PTIM);
procedure ClearSectorBuffer(SectorBuffer, ClearBuffer: PBytesArray);
protected
procedure Execute; override;
public
constructor Create(const FileToScan: string; fResult: pointer;
ImageScan: boolean);
constructor Create(const FileToScan: string; ImageScan: boolean);
property Terminated;
property StopScan: boolean write pStopScan;
end;
@@ -39,7 +37,7 @@ type
implementation
uses
uMain, uCDIMAGE, System.SysUtils, NativeXml;
uMain, uCDIMAGE, System.SysUtils;
const
cClearBufferSize = ((cTIMMaxSize div cSectorDataSize) + 1) *
@@ -48,46 +46,34 @@ const
{ TScanThread }
constructor TScanThread.Create(const FileToScan: string; fResult: pointer;
ImageScan: boolean);
var
Node: TXmlNode;
constructor TScanThread.Create(const FileToScan: string; ImageScan: boolean);
begin
inherited Create(True);
FreeOnTerminate := True;
pClearBufferPosition := 0;
pFilePos := 0;
pTims := 0;
pFileToScan := FileToScan;
pFileSize := GetFileSizeAPI(pFileToScan);
pFileSize := GetFileSizeAPI(FileToScan);
pStatusText := '';
pStopScan := False;
pImageScan := ImageScan;
pResult := fResult;
Node := pResult^.Root.NodeNew(cResInfoNode);
Node.WriteAttributeUnicodeString(cResAttrFile, pFileToScan);
Node.WriteAttributeBool(cResAttrImageFile, ImageScan);
Node.WriteAttributeInteger(cResAttrTimsCount, 0);
pScanFile := FileToScan;
pIsImage := ImageScan;
end;
procedure TScanThread.AddResult(TIM: PTIM);
var
Node, AddedNode: TXmlNode;
ScanTim: TScanTim;
begin
Node := pResult^.Root.NodeFindOrCreate(cResInfoNode);
Node.WriteAttributeInteger(cResAttrTimsCount, TIM^.dwTimNumber);
Node := pResult^.Root.NodeFindOrCreate(cResTimsNode);
AddedNode := Node.NodeNew(cResTimNode);
AddedNode.WriteAttributeInteger(cResTimAttrPos, TIM^.dwTimPosition);
AddedNode.WriteAttributeInteger(cResTimAttrSize, TIM^.dwSIZE);
AddedNode.WriteAttributeInteger(cResTimAttrWidth, GetTimRealWidth(TIM));
AddedNode.WriteAttributeInteger(cResTimAttrHeight, GetTimHeight(TIM));
AddedNode.WriteAttributeInteger(cResTimAttrBitMode, BppToBitMode(TIM));
AddedNode.WriteAttributeBool(cResTimAttrGood, TIMIsGood(TIM));
ScanTim.Position := TIM^.dwTimPosition;
ScanTim.Size := TIM^.dwSIZE;
ScanTim.Width := GetTimRealWidth(TIM);
ScanTim.Height := GetTimHeight(TIM);
ScanTim.Bitmode := BppToBitMode(TIM);
ScanTim.Good := TIMIsGood(TIM);
pScanResult.Count := TIM^.dwTimNumber;
pScanResult.ScanTim[pScanResult.Count - 1] := ScanTim;
Inc(pTims);
end;
@@ -96,13 +82,15 @@ var
SectorBuffer, ClearBuffer: PBytesArray;
TIM: PTIM;
pScanFinished: boolean;
pRealBufSize, pTimPosition, pTIMNumber: DWORD;
pRealBufSize, pTimPosition, pTIMNumber: Integer;
begin
pSrcFileStream := TFileStream.Create(pFileToScan, fmOpenRead or
Synchronize(StartScan);
pSrcFileStream := TFileStream.Create(pScanResult.ScanFile, fmOpenRead or
fmShareDenyWrite);
pSrcFileStream.Position := 0;
if pImageScan then
if pScanResult.IsImage then
pSectorBufferSize := cSectorBufferSize
else
pSectorBufferSize := cClearBufferSize;
@@ -127,15 +115,14 @@ begin
repeat
if LoadTimFromBuf(ClearBuffer, TIM, pClearBufferPosition) then
begin
if pImageScan then
if pScanResult.IsImage then
pTimPosition := pFilePos - pRealBufSize +
((pClearBufferPosition - 1) div cSectorDataSize) * cSectorSize +
((pClearBufferPosition - 1) mod cSectorDataSize) + cSectorInfoSize
else
pTimPosition := pFilePos - pRealBufSize + (pClearBufferPosition - 1);
if pTimPosition >= pFileSize then
Break;
if pTimPosition >= pFileSize then Break;
TIM^.dwTimPosition := pTimPosition;
Inc(pTIMNumber);
@@ -145,13 +132,11 @@ begin
if pClearBufferPosition = (pClearBufferSize div 2) then
begin
if pScanFinished then
Break;
if pScanFinished then Break;
pScanFinished := (pFilePos = pFileSize);
pClearBufferPosition := 0;
Move(SectorBuffer^[pSectorBufferSize div 2], SectorBuffer^[0],
pSectorBufferSize div 2);
Move(SectorBuffer^[pSectorBufferSize div 2], SectorBuffer^[0], pSectorBufferSize div 2);
if pScanFinished then
begin
@@ -161,8 +146,7 @@ begin
end
else
begin
pRealBufSize := pSrcFileStream.
Read(SectorBuffer^[pSectorBufferSize div 2], pSectorBufferSize div 2);
pRealBufSize := pSrcFileStream.Read(SectorBuffer^[pSectorBufferSize div 2], pSectorBufferSize div 2);
Inc(pFilePos, pRealBufSize);
pRealBufSize := pRealBufSize + (pSectorBufferSize div 2);
end;
@@ -191,6 +175,22 @@ begin
frmMain.lblStatus.Caption := pStatusText;
end;
procedure TScanThread.StartScan;
begin
frmMain.btnStopScan.Enabled := True;
frmMain.cbbFiles.Enabled := False;
frmMain.pnlList.Enabled := False;
frmMain.actExtractList.Enabled := False;
frmMain.pbProgress.Max := GetFileSizeAPI(pScanFile);
frmMain.pbProgress.Position := 0;
frmMain.ScanResult.Add(TScanResult.Create);
pScanResult := frmMain.ScanResult.Last;
pScanResult.ScanFile := pScanFile;
pScanResult.IsImage := pIsImage;
end;
procedure TScanThread.UpdateProgressBar;
begin
frmMain.pbProgress.Position := pFilePos;
@@ -199,10 +199,10 @@ end;
procedure TScanThread.ClearSectorBuffer(SectorBuffer, ClearBuffer: PBytesArray);
var
i: DWORD;
i: Integer;
begin
FillChar(ClearBuffer^[0], pClearBufferSize, 0);
if not pImageScan then
if not pScanResult.IsImage then
begin
Move(SectorBuffer^[0], ClearBuffer^[0], pClearBufferSize);
Exit;

70
units/uTIM.pas
View File

@@ -44,7 +44,7 @@ type
bVersion: byte; // Any? (1 byte)
bReserved1: byte; // Reserved byte 1 (1 byte)
bReserved2: byte; // Reserved byte 2 (1 byte)
bBPP: DWORD; // Bit per Pixel (4 bytes)
bBPP: Integer; // Bit per Pixel (4 bytes)
// variants:
// [$08, $09, $0A, $0B, $02, $03, $00, $01]
end;
@@ -53,7 +53,7 @@ type
type
TCLUTHeader = packed record // CLUT header (12+ bytes)
dwSize: DWORD; // Length of CLUT (4 bytes)
dwSize: Integer; // Length of CLUT (4 bytes)
wVRAMX: word; // Palette coordinates in VRAM (by X) (2 bytes)
wVRAMY: word; // Palette coordinates in VRAM (by Y) (2 bytes)
wColorsCount: word; // Number of CLUT Colors (2 bytes)
@@ -64,7 +64,7 @@ type
type
TIMAGEHeader = packed record // IMAGE Block Header (12+ bytes)
dwSize: DWORD; // Length of Image Block (4 bytes)
dwSize: Integer; // Length of Image Block (4 bytes)
wVRAMX: word; // Image Block Coordinates in VRAM (by X) (2 bytes)
wVRAMY: word; // Image Block Coordinates in VRAM (by Y) (2 bytes)
wWidth: word; // Image Width (not Real) (2 bytes)
@@ -93,17 +93,17 @@ type
type
TIMAGE_INDEXES = array [0 .. cIMAGEWidthMax * cIMAGEHeightMax * 4 -
1] of DWORD;
1] of Integer;
PIMAGE_INDEXES = ^TIMAGE_INDEXES;
type
TTIM = record
dwTimNumber: DWORD;
dwTimPosition: DWORD;
dwTimNumber: Integer;
dwTimPosition: Integer;
HEAD: PTIMHeader;
CLUT: PCLUTHeader;
IMAGE: PIMAGEHeader;
dwSize: DWORD;
dwSize: Integer;
DATA: PTIMDataArray;
bGOOD: Boolean;
end;
@@ -111,16 +111,16 @@ type
PTIM = ^TTIM;
function TIMHasCLUT(TIM: PTIM): Boolean;
function GetTIMCLUTSize(TIM: PTIM): DWORD;
function GetTIMSize(TIM: PTIM): DWORD;
function GetTIMCLUTSize(TIM: PTIM): Integer;
function GetTIMSize(TIM: PTIM): Integer;
function GetTimWidth(TIM: PTIM): word;
function GetTimRealWidth(TIM: PTIM): word;
function GetTimHeight(TIM: PTIM): word;
function TIMIsGood(TIM: PTIM): Boolean;
function LoadTimFromBuf(BUFFER: pointer; var TIM: PTIM;
var Position: DWORD): Boolean;
function LoadTimFromFile(const FileName: string; var Position: DWORD;
ImageScan: Boolean; dwSize: DWORD): PTIM;
var Position: Integer): Boolean;
function LoadTimFromFile(const FileName: string; var Position: Integer;
ImageScan: Boolean; dwSize: Integer): PTIM;
procedure SaveTimToFile(const FileName: string; TIM: PTIM);
function CreateTIM: PTIM;
procedure FreeTIM(TIM: PTIM);
@@ -128,14 +128,14 @@ function BppToBitMode(TIM: PTIM): byte;
function GetTimColorsCount(TIM: PTIM): word;
function GetTimClutsCount(TIM: PTIM): word;
function GetTimVersion(TIM: PTIM): byte;
function GetTimBPP(TIM: PTIM): DWORD;
function GetTimClutSizeHeader(TIM: PTIM): DWORD;
function GetTimBPP(TIM: PTIM): Integer;
function GetTimClutSizeHeader(TIM: PTIM): Integer;
function GetTimClutVRAMX(TIM: PTIM): word;
function GetTimClutVRAMY(TIM: PTIM): word;
function GetTimImageSizeHeader(TIM: PTIM): DWORD;
function GetTimImageSizeHeader(TIM: PTIM): Integer;
function GetTimImageVRAMX(TIM: PTIM): word;
function GetTimImageVRAMY(TIM: PTIM): word;
function GetTIMIMAGESize(TIM: PTIM): DWORD;
function GetTIMIMAGESize(TIM: PTIM): Integer;
function GetCLUTColor(TIM: PTIM; CLUT_NUM, COLOR_NUM: Integer): TCLUT_COLOR;
procedure WriteCLUTColor(TIM: PTIM; CLUT_NUM, COLOR_NUM: Integer;
COLOR: TCLUT_COLOR);
@@ -201,7 +201,7 @@ begin
Result := TIM^.IMAGE^.wHeight;
end;
function GetTIMCLUTSize(TIM: PTIM): DWORD;
function GetTIMCLUTSize(TIM: PTIM): Integer;
begin
Result := 0;
@@ -211,12 +211,12 @@ begin
cCLUTHeadSize;
end;
function GetTIMIMAGESize(TIM: PTIM): DWORD;
function GetTIMIMAGESize(TIM: PTIM): Integer;
begin
Result := TIM^.IMAGE^.wWidth * TIM^.IMAGE^.wHeight * 2 + cIMAGEHeadSize;
end;
function GetTIMSize(TIM: PTIM): DWORD;
function GetTIMSize(TIM: PTIM): Integer;
begin
Result := GetTIMCLUTSize(TIM) + GetTIMIMAGESize(TIM) + cTIMHeadSize;
end;
@@ -320,10 +320,10 @@ begin
end;
function LoadTimFromBuf(BUFFER: pointer; var TIM: PTIM;
var Position: DWORD): Boolean;
var Position: Integer): Boolean;
var
P: DWORD;
TIM_POS: DWORD;
P: Integer;
TIM_POS: Integer;
begin
Result := False;
@@ -362,15 +362,15 @@ begin
Result := True;
end;
function LoadTimFromCDFile(const FileName: string; var Position: DWORD;
SIZE: DWORD): PTIM;
function LoadTimFromCDFile(const FileName: string; var Position: Integer;
SIZE: Integer): PTIM;
var
TimOffsetInSector, FirstPartSize, LastPartSize: DWORD;
TimSectorNumber, TimStartSectorPos: DWORD;
TimOffsetInSector, FirstPartSize, LastPartSize: Integer;
TimSectorNumber, TimStartSectorPos: Integer;
TIM_BUF: PTIMDataArray;
sImageStream: TFileStream;
Sector: TCDSector;
P, TIM_FULL_SECTORS: DWORD;
P, TIM_FULL_SECTORS: Integer;
begin
sImageStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
@@ -424,11 +424,11 @@ begin
Dispose(TIM_BUF);
end;
function LoadTimFromStream(Stream: TStream; var Position: DWORD;
dwSize: DWORD): PTIM;
function LoadTimFromStream(Stream: TStream; var Position: Integer;
dwSize: Integer): PTIM;
var
BUF: PTIMDataArray;
P: DWORD;
P: Integer;
begin
Result := nil;
@@ -448,8 +448,8 @@ begin
Dispose(BUF);
end;
function LoadTimFromFile(const FileName: string; var Position: DWORD;
ImageScan: Boolean; dwSize: DWORD): PTIM;
function LoadTimFromFile(const FileName: string; var Position: Integer;
ImageScan: Boolean; dwSize: Integer): PTIM;
var
sTIM: TFileStream;
begin
@@ -560,12 +560,12 @@ begin
Result := TIM^.CLUT^.wClutsCount;
end;
function GetTimBPP(TIM: PTIM): DWORD;
function GetTimBPP(TIM: PTIM): Integer;
begin
Result := TIM^.HEAD^.bBPP;
end;
function GetTimClutSizeHeader(TIM: PTIM): DWORD;
function GetTimClutSizeHeader(TIM: PTIM): Integer;
begin
Result := TIM^.CLUT^.dwSize;
end;
@@ -580,7 +580,7 @@ begin
Result := TIM^.CLUT^.wVRAMY;
end;
function GetTimImageSizeHeader(TIM: PTIM): DWORD;
function GetTimImageSizeHeader(TIM: PTIM): Integer;
begin
Result := TIM^.IMAGE^.dwSize;
end;