ImagingUtility.pas 41 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566
  1. {
  2. $Id$
  3. Vampyre Imaging Library
  4. by Marek Mauder
  5. http://imaginglib.sourceforge.net
  6. The contents of this file are used with permission, subject to the Mozilla
  7. Public License Version 1.1 (the "License"); you may not use this file except
  8. in compliance with the License. You may obtain a copy of the License at
  9. http://www.mozilla.org/MPL/MPL-1.1.html
  10. Software distributed under the License is distributed on an "AS IS" basis,
  11. WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
  12. the specific language governing rights and limitations under the License.
  13. Alternatively, the contents of this file may be used under the terms of the
  14. GNU Lesser General Public License (the "LGPL License"), in which case the
  15. provisions of the LGPL License are applicable instead of those above.
  16. If you wish to allow use of your version of this file only under the terms
  17. of the LGPL License and not to allow others to use your version of this file
  18. under the MPL, indicate your decision by deleting the provisions above and
  19. replace them with the notice and other provisions required by the LGPL
  20. License. If you do not delete the provisions above, a recipient may use
  21. your version of this file under either the MPL or the LGPL License.
  22. For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
  23. }
  24. { This unit contains utility functions and types for Imaging library.}
  25. unit ImagingUtility;
  26. {$I ImagingOptions.inc}
  27. interface
  28. uses
  29. SysUtils, Classes, Types;
  30. const
  31. STrue = 'True';
  32. SFalse = 'False';
  33. type
  34. TByteArray = array[0..MaxInt - 1] of Byte;
  35. PByteArray = ^TByteArray;
  36. TWordArray = array[0..MaxInt div 2 - 1] of Word;
  37. PWordArray = ^TWordArray;
  38. TLongIntArray = array[0..MaxInt div 4 - 1] of LongInt;
  39. PLongIntArray = ^TLongIntArray;
  40. TLongWordArray = array[0..MaxInt div 4 - 1] of LongWord;
  41. PLongWordArray = ^TLongWordArray;
  42. TInt64Array = array[0..MaxInt div 8 - 1] of Int64;
  43. PInt64Array = ^TInt64Array;
  44. TSingleArray = array[0..MaxInt div 4 - 1] of Single;
  45. PSingleArray = ^TSingleArray;
  46. TBooleanArray = array[0..MaxInt - 1] of Boolean;
  47. PBooleanArray = ^TBooleanArray;
  48. TWordRec = packed record
  49. case Integer of
  50. 0: (WordValue: Word);
  51. 1: (Low, High: Byte);
  52. end;
  53. PWordRec = ^TWordRec;
  54. TWordRecArray = array[0..MaxInt div 2 - 1] of TWordRec;
  55. PWordRecArray = ^TWordRecArray;
  56. TLongWordRec = packed record
  57. case Integer of
  58. 0: (LongWordValue: LongWord);
  59. 1: (Low, High: Word);
  60. { Array variants - Index 0 means lowest significant byte (word, ...).}
  61. 2: (Words: array[0..1] of Word);
  62. 3: (Bytes: array[0..3] of Byte);
  63. end;
  64. PLongWordRec = ^TLongWordRec;
  65. TLongWordRecArray = array[0..MaxInt div 4 - 1] of TLongWordRec;
  66. PLongWordRecArray = ^TLongWordRecArray;
  67. TInt64Rec = packed record
  68. case Integer of
  69. 0: (Int64Value: Int64);
  70. 1: (Low, High: LongWord);
  71. { Array variants - Index 0 means lowest significant byte (word, ...).}
  72. 2: (Words: array[0..3] of Word);
  73. 3: (Bytes: array[0..7] of Byte);
  74. end;
  75. PInt64Rec = ^TInt64Rec;
  76. TInt64RecArray = array[0..MaxInt div 8 - 1] of TInt64Rec;
  77. PInt64RecArray = ^TInt64RecArray;
  78. TFloatHelper = record
  79. Data1: Int64;
  80. Data2: Int64;
  81. end;
  82. PFloatHelper = ^TFloatHelper;
  83. TChar2 = array[0..1] of Char;
  84. TChar3 = array[0..2] of Char;
  85. TChar4 = array[0..3] of Char;
  86. TChar8 = array[0..7] of Char;
  87. { Options for BuildFileList function:
  88. flFullNames - file names in result will have full path names
  89. (ExtractFileDir(Path) + FileName)
  90. flRelNames - file names in result will have names relative to
  91. ExtractFileDir(Path) dir
  92. flRecursive - adds files in subdirectories found in Path.}
  93. TFileListOption = (flFullNames, flRelNames, flRecursive);
  94. TFileListOptions = set of TFileListOption;
  95. { Frees class instance and sets its reference to nil.}
  96. procedure FreeAndNil(var Obj);
  97. { Frees pointer and sets it to nil.}
  98. procedure FreeMemNil(var P); {$IFDEF USE_INLINE}inline;{$ENDIF}
  99. { Replacement of standard System.FreeMem procedure which checks if P is nil
  100. (this is only needed for Free Pascal, Delphi makes checks in its FreeMem).}
  101. procedure FreeMem(P: Pointer); {$IFDEF USE_INLINE}inline;{$ENDIF}
  102. { Returns current exception object. Do not call outside exception handler.}
  103. function GetExceptObject: Exception; {$IFDEF USE_INLINE}inline;{$ENDIF}
  104. { Returns time value with microsecond resolution. Use for some time counters.}
  105. function GetTimeMicroseconds: Int64;
  106. { Returns file extension (without "." dot)}
  107. function GetFileExt(const FileName: string): string;
  108. { Returns file name of application's executable.}
  109. function GetAppExe: string;
  110. { Returns directory where application's exceutable is located without
  111. path delimiter at the end.}
  112. function GetAppDir:string;
  113. { Returns True if FileName matches given Mask with optional case sensitivity.
  114. Mask can contain ? and * special characters: ? matches
  115. one character, * matches zero or more characters.}
  116. function MatchFileNameMask(const FileName, Mask: string; CaseSensitive: Boolean = False): Boolean;
  117. { This function fills Files string list with names of files found
  118. with FindFirst/FindNext functions (See details on Path/Atrr here).
  119. - BuildFileList('c:\*.*', faAnyFile, List, [flRecursive]) returns
  120. list of all files (only name.ext - no path) on C drive
  121. - BuildFileList('d:\*.*', faDirectory, List, [flFullNames]) returns
  122. list of all directories (d:\dirxxx) in root of D drive.}
  123. function BuildFileList(Path: string; Attr: LongInt; Files: TStrings;
  124. Options: TFileListOptions = []): Boolean;
  125. { Similar to RTL's Pos function but with optional Offset where search will start.
  126. This function is in the RTL StrUtils unit but }
  127. function PosEx(const SubStr, S: string; Offset: LongInt = 1): LongInt;
  128. { Same as PosEx but without case sensitivity.}
  129. function PosNoCase(const SubStr, S: string; Offset: LongInt = 1): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
  130. { Returns a sub-string from S which is followed by
  131. Sep separator and deletes the sub-string from S including the separator.}
  132. function StrToken(var S: string; Sep: Char): string;
  133. { Same as StrToken but searches from the end of S string.}
  134. function StrTokenEnd(var S: string; Sep: Char): string;
  135. { Clamps integer value to range <Min, Max>}
  136. function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
  137. { Clamps float value to range <Min, Max>}
  138. function ClampFloat(Number: Single; Min, Max: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
  139. { Clamps integer value to Byte boundaries.}
  140. function ClampToByte(Value: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
  141. { Clamps integer value to Word boundaries.}
  142. function ClampToWord(Value: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
  143. { Returns True if Num is power of 2.}
  144. function IsPow2(Num: LongInt): Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
  145. { Returns next power of 2 greater than or equal to Num
  146. (if Num itself is power of 2 then it retuns Num).}
  147. function NextPow2(Num: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
  148. { Raises 2 to the given integer power (in range [0, 30]).}
  149. function Pow2Int(Exponent: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
  150. { Raises Base to any power.}
  151. function Power(const Base, Exponent: Single): Single;
  152. { Returns log base 2 of integer X (max 2^30) or -1 if X is not power of 2.}
  153. function Log2Int(X: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
  154. { Returns log base 2 of X.}
  155. function Log2(X: Single): Single;
  156. { Returns largest integer <= Val (for 5.9 returns 5).}
  157. function Floor(Value: Single): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
  158. { Returns smallest integer >= Val (for 5.1 returns 6).}
  159. function Ceil(Value: Single): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
  160. { Returns lesser of two integer numbers.}
  161. function Min(A, B: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
  162. { Returns lesser of two float numbers.}
  163. function MinFloat(A, B: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
  164. { Returns greater of two integer numbers.}
  165. function Max(A, B: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
  166. { Returns greater of two float numbers.}
  167. function MaxFloat(A, B: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
  168. { Returns result from multiplying Number by Numerator and then dividing by Denominator.
  169. Denominator must be greater than 0.}
  170. function MulDiv(Number, Numerator, Denominator: Word): Word; {$IFDEF USE_INLINE}inline;{$ENDIF}
  171. { Switches Boolean value.}
  172. procedure Switch(var Value: Boolean); {$IFDEF USE_INLINE}inline;{$ENDIF}
  173. { If Condition is True then TruePart is retured, otherwise
  174. FalsePart is returned.}
  175. function Iff(Condition: Boolean; TruePart, FalsePart: LongInt): LongInt; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  176. { If Condition is True then TruePart is retured, otherwise
  177. FalsePart is returned.}
  178. function IffUnsigned(Condition: Boolean; TruePart, FalsePart: LongWord): LongWord; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  179. { If Condition is True then TruePart is retured, otherwise
  180. FalsePart is returned.}
  181. function Iff(Condition, TruePart, FalsePart: Boolean): Boolean; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  182. { If Condition is True then TruePart is retured, otherwise
  183. FalsePart is returned.}
  184. function Iff(Condition: Boolean; const TruePart, FalsePart: string): string; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  185. { If Condition is True then TruePart is retured, otherwise
  186. FalsePart is returned.}
  187. function Iff(Condition: Boolean; TruePart, FalsePart: Char): Char; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  188. { If Condition is True then TruePart is retured, otherwise
  189. FalsePart is returned.}
  190. function Iff(Condition: Boolean; TruePart, FalsePart: Pointer): Pointer; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  191. { If Condition is True then TruePart is retured, otherwise
  192. FalsePart is returned.}
  193. function Iff(Condition: Boolean; const TruePart, FalsePart: Int64): Int64; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  194. { If Condition is True then TruePart is retured, otherwise
  195. FalsePart is returned.}
  196. function IffFloat(Condition: Boolean; TruePart, FalsePart: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
  197. { Swaps two Byte values}
  198. procedure SwapValues(var A, B: Byte); overload;
  199. { Swaps two Word values}
  200. procedure SwapValues(var A, B: Word); overload;
  201. { Swaps two LongInt values}
  202. procedure SwapValues(var A, B: LongInt); overload;
  203. { Swaps two Single values}
  204. procedure SwapValues(var A, B: Single); overload;
  205. { Swaps two LongInt values if necessary to ensure that Min <= Max.}
  206. procedure SwapMin(var Min, Max: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
  207. { This function returns True if running on little endian machine.}
  208. function IsLittleEndian: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
  209. { Swaps byte order of Word value.}
  210. function SwapEndianWord(Value: Word): Word; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  211. { Swaps byte order of multiple Word values.}
  212. procedure SwapEndianWord(P: PWordArray; Count: LongInt); overload;
  213. { Swaps byte order of LongWord value.}
  214. function SwapEndianLongWord(Value: LongWord): LongWord; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  215. { Swaps byte order of multiple LongWord values.}
  216. procedure SwapEndianLongWord(P: PLongWord; Count: LongInt); overload;
  217. { Calculates CRC32 for the given data.}
  218. procedure CalcCrc32(var Crc: LongWord; Data: Pointer; Size: LongInt);
  219. { Fills given memory with given Byte value. Size is size of buffer in bytes.}
  220. procedure FillMemoryByte(Data: Pointer; Size: LongInt; Value: Byte);
  221. { Fills given memory with given Word value. Size is size of buffer in bytes.}
  222. procedure FillMemoryWord(Data: Pointer; Size: LongInt; Value: Word);
  223. { Fills given memory with given LongWord value. Size is size of buffer in bytes.}
  224. procedure FillMemoryLongWord(Data: Pointer; Size: LongInt; Value: LongWord);
  225. { Returns how many mipmap levels can be created for image of given size.}
  226. function GetNumMipMapLevels(Width, Height: LongInt): LongInt;
  227. { Returns total number of levels of volume texture with given depth and
  228. mipmap count (this is not depth * mipmaps!).}
  229. function GetVolumeLevelCount(Depth, MipMaps: LongInt): LongInt;
  230. { Returns rectangle (X, Y, X + Width, Y + Height).}
  231. function BoundsToRect(X, Y, Width, Height: LongInt): TRect; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  232. { Returns rectangle (R.Left, R.Top, R.Left + R.Right, R.Top + R.Bottom).}
  233. function BoundsToRect(const R: TRect): TRect; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  234. { Returns rectangle (R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top).}
  235. function RectToBounds(const R: TRect): TRect; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  236. { Clips given bounds to Clip rectangle.}
  237. procedure ClipRectBounds(var X, Y, Width, Height: LongInt; const Clip: TRect);
  238. { Clips given source bounds and dest position. It is used by various CopyRect
  239. functions that copy rect from one image to another. It handles clipping the same way
  240. as Win32 BitBlt function. }
  241. procedure ClipCopyBounds(var SrcX, SrcY, Width, Height, DstX, DstY: LongInt;
  242. SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect);
  243. { Clips given source bounds and dest bounds. It is used by various StretchRect
  244. functions that stretch rectangle of pixels from one image to another.
  245. It handles clipping the same way as Win32 StretchBlt function. }
  246. procedure ClipStretchBounds(var SrcX, SrcY, SrcWidth, SrcHeight, DstX, DstY,
  247. DstWidth, DstHeight: LongInt; SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect);
  248. { Scales one rectangle to fit into another. Proportions are preserved so
  249. it could be used for 'Stretch To Fit Window' image drawing for instance.}
  250. function ScaleRectToRect(const SourceRect, TargetRect: TRect): TRect;
  251. { Returns True if R1 fits into R2.}
  252. function RectInRect(const R1, R2: TRect): Boolean;
  253. { Returns True if R1 and R2 intersects.}
  254. function RectIntersects(const R1, R2: TRect): Boolean;
  255. { Formats given message for usage in Exception.Create(..). Use only
  256. in except block - returned message contains message of last raised exception.}
  257. function FormatExceptMsg(const Msg: string; const Args: array of const): string;
  258. { Outputs debug message - shows message dialog in Windows and writes to console
  259. in Linux/Unix.}
  260. procedure DebugMsg(const Msg: string; const Args: array of const);
  261. implementation
  262. uses
  263. {$IFDEF MSWINDOWS}
  264. Windows;
  265. {$ENDIF}
  266. {$IFDEF UNIX}
  267. {$IFDEF KYLIX}
  268. Libc;
  269. {$ELSE}
  270. Dos, BaseUnix, Unix;
  271. {$ENDIF}
  272. {$ENDIF}
  273. procedure FreeAndNil(var Obj);
  274. var
  275. Temp: TObject;
  276. begin
  277. Temp := TObject(Obj);
  278. Pointer(Obj) := nil;
  279. Temp.Free;
  280. end;
  281. procedure FreeMemNil(var P);
  282. begin
  283. FreeMem(Pointer(P));
  284. Pointer(P) := nil;
  285. end;
  286. procedure FreeMem(P: Pointer);
  287. begin
  288. if P <> nil then
  289. System.FreeMem(P);
  290. end;
  291. function GetExceptObject: Exception;
  292. begin
  293. Result := Exception(ExceptObject);
  294. end;
  295. {$IFDEF MSWINDOWS}
  296. var
  297. PerfFrequency: Int64;
  298. InvPerfFrequency: Single;
  299. function GetTimeMicroseconds: Int64;
  300. var
  301. Time: Int64;
  302. begin
  303. QueryPerformanceCounter(Time);
  304. Result := Round(1000000 * InvPerfFrequency * Time);
  305. end;
  306. {$ENDIF}
  307. {$IFDEF UNIX}
  308. function GetTimeMicroseconds: Int64;
  309. var
  310. TimeVal: TTimeVal;
  311. begin
  312. {$IFDEF KYLIX}
  313. GetTimeOfDay(TimeVal, nil);
  314. {$ELSE}
  315. fpGetTimeOfDay(@TimeVal, nil);
  316. {$ENDIF}
  317. Result := Int64(TimeVal.tv_sec) * 1000000 + TimeVal.tv_usec;
  318. end;
  319. {$ENDIF}
  320. {$IFDEF MSDOS}
  321. function GetTimeMicroseconds: Int64;
  322. asm
  323. XOR EAX, EAX
  324. CLI
  325. OUT $43, AL
  326. MOV EDX, FS:[$46C]
  327. IN AL, $40
  328. DB $EB, 0, $EB, 0, $EB, 0
  329. MOV AH, AL
  330. IN AL, $40
  331. DB $EB, 0, $EB, 0, $EB, 0
  332. XCHG AL, AH
  333. NEG AX
  334. MOVZX EDI, AX
  335. STI
  336. MOV EBX, $10000
  337. MOV EAX, EDX
  338. XOR EDX, EDX
  339. MUL EBX
  340. ADD EAX, EDI
  341. ADC EDX, 0
  342. PUSH EDX
  343. PUSH EAX
  344. MOV ECX, $82BF1000
  345. MOVZX EAX, WORD PTR FS:[$470]
  346. MUL ECX
  347. MOV ECX, EAX
  348. POP EAX
  349. POP EDX
  350. ADD EAX, ECX
  351. ADC EDX, 0
  352. end;
  353. {$ENDIF}
  354. function GetFileExt(const FileName: string): string;
  355. begin
  356. Result := ExtractFileExt(FileName);
  357. if Length(Result) > 1 then
  358. Delete(Result, 1, 1);
  359. end;
  360. function GetAppExe: string;
  361. {$IFDEF MSWINDOWS}
  362. var
  363. FileName: array[0..MAX_PATH] of Char;
  364. begin
  365. SetString(Result, FileName,
  366. Windows.GetModuleFileName(MainInstance, FileName, SizeOf(FileName)));
  367. {$ENDIF}
  368. {$IFDEF UNIX}
  369. {$IFDEF KYLIX}
  370. var
  371. FileName: array[0..FILENAME_MAX] of Char;
  372. begin
  373. SetString(Result, FileName,
  374. System.GetModuleFileName(MainInstance, FileName, SizeOf(FileName)));
  375. {$ELSE}
  376. begin
  377. Result := FExpand(ParamStr(0));
  378. {$ENDIF}
  379. {$ENDIF}
  380. {$IFDEF MSDOS}
  381. begin
  382. Result := ParamStr(0);
  383. {$ENDIF}
  384. end;
  385. function GetAppDir:string;
  386. begin
  387. Result := ExtractFileDir(GetAppExe);
  388. end;
  389. function MatchFileNameMask(const FileName, Mask: string; CaseSensitive: Boolean): Boolean;
  390. var
  391. MaskLen, KeyLen : LongInt;
  392. function CharMatch(A, B: Char): Boolean;
  393. begin
  394. if CaseSensitive then
  395. Result := A = B
  396. else
  397. Result := UpCase(A) = UpCase(B);
  398. end;
  399. function MatchAt(MaskPos, KeyPos: LongInt): Boolean;
  400. begin
  401. while (MaskPos <= MaskLen) and (KeyPos <= KeyLen) do
  402. begin
  403. case Mask[MaskPos] of
  404. '?' :
  405. begin
  406. Inc(MaskPos);
  407. Inc(KeyPos);
  408. end;
  409. '*' :
  410. begin
  411. while (MaskPos <= MaskLen) and (Mask[MaskPos] = '*') do
  412. Inc(MaskPos);
  413. if MaskPos > MaskLen then
  414. begin
  415. Result := True;
  416. Exit;
  417. end;
  418. repeat
  419. if MatchAt(MaskPos, KeyPos) then
  420. begin
  421. Result := True;
  422. Exit;
  423. end;
  424. Inc(KeyPos);
  425. until KeyPos > KeyLen;
  426. Result := False;
  427. Exit;
  428. end;
  429. else
  430. if not CharMatch(Mask[MaskPos], FileName[KeyPos]) then
  431. begin
  432. Result := False;
  433. Exit;
  434. end
  435. else
  436. begin
  437. Inc(MaskPos);
  438. Inc(KeyPos);
  439. end;
  440. end;
  441. end;
  442. while (MaskPos <= MaskLen) and (Mask[MaskPos] in ['?', '*']) do
  443. Inc(MaskPos);
  444. if (MaskPos <= MaskLen) or (KeyPos <= KeyLen) then
  445. begin
  446. Result := False;
  447. Exit;
  448. end;
  449. Result := True;
  450. end;
  451. begin
  452. MaskLen := Length(Mask);
  453. KeyLen := Length(FileName);
  454. if MaskLen = 0 then
  455. begin
  456. Result := True;
  457. Exit;
  458. end;
  459. Result := MatchAt(1, 1);
  460. end;
  461. function BuildFileList(Path: string; Attr: LongInt;
  462. Files: TStrings; Options: TFileListOptions): Boolean;
  463. var
  464. FileMask: string;
  465. RootDir: string;
  466. Folders: TStringList;
  467. CurrentItem: LongInt;
  468. Counter: LongInt;
  469. LocAttr: LongInt;
  470. procedure BuildFolderList;
  471. var
  472. FindInfo: TSearchRec;
  473. Rslt: LongInt;
  474. begin
  475. Counter := Folders.Count - 1;
  476. CurrentItem := 0;
  477. while CurrentItem <= Counter do
  478. begin
  479. // Searching for subfolders
  480. Rslt := SysUtils.FindFirst(Folders[CurrentItem] + '*', faDirectory, FindInfo);
  481. try
  482. while Rslt = 0 do
  483. begin
  484. if (FindInfo.Name <> '.') and (FindInfo.Name <> '..') and
  485. (FindInfo.Attr and faDirectory = faDirectory) then
  486. Folders.Add(Folders[CurrentItem] + FindInfo.Name + PathDelim);
  487. Rslt := SysUtils.FindNext(FindInfo);
  488. end;
  489. finally
  490. SysUtils.FindClose(FindInfo);
  491. end;
  492. Counter := Folders.Count - 1;
  493. Inc(CurrentItem);
  494. end;
  495. end;
  496. procedure FillFileList(CurrentCounter: LongInt);
  497. var
  498. FindInfo: TSearchRec;
  499. Res: LongInt;
  500. CurrentFolder: string;
  501. begin
  502. CurrentFolder := Folders[CurrentCounter];
  503. Res := SysUtils.FindFirst(CurrentFolder + FileMask, LocAttr, FindInfo);
  504. if flRelNames in Options then
  505. CurrentFolder := ExtractRelativePath(RootDir, CurrentFolder);
  506. try
  507. while Res = 0 do
  508. begin
  509. if (FindInfo.Name <> '.') and (FindInfo.Name <> '..') then
  510. begin
  511. if (flFullNames in Options) or (flRelNames in Options) then
  512. Files.Add(CurrentFolder + FindInfo.Name)
  513. else
  514. Files.Add(FindInfo.Name);
  515. end;
  516. Res := SysUtils.FindNext(FindInfo);
  517. end;
  518. finally
  519. SysUtils.FindClose(FindInfo);
  520. end;
  521. end;
  522. begin
  523. FileMask := ExtractFileName(Path);
  524. RootDir := ExtractFilePath(Path);
  525. Folders := TStringList.Create;
  526. Folders.Add(RootDir);
  527. Files.Clear;
  528. {$IFDEF DCC}
  529. {$WARN SYMBOL_PLATFORM OFF}
  530. {$ENDIF}
  531. if Attr = faAnyFile then
  532. LocAttr := faSysFile or faHidden or faArchive or faReadOnly
  533. else
  534. LocAttr := Attr;
  535. {$IFDEF DCC}
  536. {$WARN SYMBOL_PLATFORM ON}
  537. {$ENDIF}
  538. // Here's the recursive search for nested folders
  539. if flRecursive in Options then
  540. BuildFolderList;
  541. if Attr <> faDirectory then
  542. for Counter := 0 to Folders.Count - 1 do
  543. FillFileList(Counter)
  544. else
  545. Files.AddStrings(Folders);
  546. Folders.Free;
  547. Result := True;
  548. end;
  549. function PosEx(const SubStr, S: string; Offset: LongInt = 1): LongInt;
  550. {$IFDEF USE_ASM}
  551. asm
  552. // The Original ASM Code is (C) Fastcode project.
  553. test eax, eax
  554. jz @Nil
  555. test edx, edx
  556. jz @Nil
  557. dec ecx
  558. jl @Nil
  559. push esi
  560. push ebx
  561. mov esi, [edx-4] //Length(Str)
  562. mov ebx, [eax-4] //Length(Substr)
  563. sub esi, ecx //effective length of Str
  564. add edx, ecx //addr of the first char at starting position
  565. cmp esi, ebx
  566. jl @Past //jump if EffectiveLength(Str)<Length(Substr)
  567. test ebx, ebx
  568. jle @Past //jump if Length(Substr)<=0
  569. add esp, -12
  570. add ebx, -1 //Length(Substr)-1
  571. add esi, edx //addr of the terminator
  572. add edx, ebx //addr of the last char at starting position
  573. mov [esp+8], esi //save addr of the terminator
  574. add eax, ebx //addr of the last char of Substr
  575. sub ecx, edx //-@Str[Length(Substr)]
  576. neg ebx //-(Length(Substr)-1)
  577. mov [esp+4], ecx //save -@Str[Length(Substr)]
  578. mov [esp], ebx //save -(Length(Substr)-1)
  579. movzx ecx, byte ptr [eax] //the last char of Substr
  580. @Loop:
  581. cmp cl, [edx]
  582. jz @Test0
  583. @AfterTest0:
  584. cmp cl, [edx+1]
  585. jz @TestT
  586. @AfterTestT:
  587. add edx, 4
  588. cmp edx, [esp+8]
  589. jb @Continue
  590. @EndLoop:
  591. add edx, -2
  592. cmp edx, [esp+8]
  593. jb @Loop
  594. @Exit:
  595. add esp, 12
  596. @Past:
  597. pop ebx
  598. pop esi
  599. @Nil:
  600. xor eax, eax
  601. ret
  602. @Continue:
  603. cmp cl, [edx-2]
  604. jz @Test2
  605. cmp cl, [edx-1]
  606. jnz @Loop
  607. @Test1:
  608. add edx, 1
  609. @Test2:
  610. add edx, -2
  611. @Test0:
  612. add edx, -1
  613. @TestT:
  614. mov esi, [esp]
  615. test esi, esi
  616. jz @Found
  617. @String:
  618. movzx ebx, word ptr [esi+eax]
  619. cmp bx, word ptr [esi+edx+1]
  620. jnz @AfterTestT
  621. cmp esi, -2
  622. jge @Found
  623. movzx ebx, word ptr [esi+eax+2]
  624. cmp bx, word ptr [esi+edx+3]
  625. jnz @AfterTestT
  626. add esi, 4
  627. jl @String
  628. @Found:
  629. mov eax, [esp+4]
  630. add edx, 2
  631. cmp edx, [esp+8]
  632. ja @Exit
  633. add esp, 12
  634. add eax, edx
  635. pop ebx
  636. pop esi
  637. end;
  638. {$ELSE}
  639. var
  640. I, X: LongInt;
  641. Len, LenSubStr: LongInt;
  642. begin
  643. I := Offset;
  644. LenSubStr := Length(SubStr);
  645. Len := Length(S) - LenSubStr + 1;
  646. while I <= Len do
  647. begin
  648. if S[I] = SubStr[1] then
  649. begin
  650. X := 1;
  651. while (X < LenSubStr) and (S[I + X] = SubStr[X + 1]) do
  652. Inc(X);
  653. if (X = LenSubStr) then
  654. begin
  655. Result := I;
  656. Exit;
  657. end;
  658. end;
  659. Inc(I);
  660. end;
  661. Result := 0;
  662. end;
  663. {$ENDIF}
  664. function PosNoCase(const SubStr, S: string; Offset: LongInt): LongInt;
  665. begin
  666. Result := PosEx(LowerCase(SubStr), LowerCase(S), Offset);
  667. end;
  668. function StrToken(var S: string; Sep: Char): string;
  669. var
  670. I: LongInt;
  671. begin
  672. I := Pos(Sep, S);
  673. if I <> 0 then
  674. begin
  675. Result := Copy(S, 1, I - 1);
  676. Delete(S, 1, I);
  677. end
  678. else
  679. begin
  680. Result := S;
  681. S := '';
  682. end;
  683. end;
  684. function StrTokenEnd(var S: string; Sep: Char): string;
  685. var
  686. I, J: LongInt;
  687. begin
  688. J := 0;
  689. I := Pos(Sep, S);
  690. while I <> 0 do
  691. begin
  692. J := I;
  693. I := PosEx(Sep, S, J + 1);
  694. end;
  695. if J <> 0 then
  696. begin
  697. Result := Copy(S, J + 1, MaxInt);
  698. Delete(S, J, MaxInt);
  699. end
  700. else
  701. begin
  702. Result := S;
  703. S := '';
  704. end;
  705. end;
  706. function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt;
  707. begin
  708. Result := Number;
  709. if Result < Min then
  710. Result := Min
  711. else
  712. if Result > Max then
  713. Result := Max;
  714. end;
  715. function ClampFloat(Number: Single; Min, Max: Single): Single;
  716. begin
  717. Result := Number;
  718. if Result < Min then
  719. Result := Min
  720. else
  721. if Result > Max then
  722. Result := Max;
  723. end;
  724. function ClampToByte(Value: LongInt): LongInt;
  725. begin
  726. Result := Value;
  727. if Result > 255 then
  728. Result := 255
  729. else if Result < 0 then
  730. Result := 0;
  731. end;
  732. function ClampToWord(Value: LongInt): LongInt;
  733. begin
  734. Result := Value;
  735. if Result > 65535 then
  736. Result := 65535
  737. else if Result < 0 then
  738. Result := 0;
  739. end;
  740. function IsPow2(Num: LongInt): Boolean;
  741. begin
  742. Result := (Num and -Num) = Num;
  743. end;
  744. function NextPow2(Num: LongInt): LongInt;
  745. begin
  746. Result := Num and -Num;
  747. while (Result < Num) do
  748. Result := Result shl 1;
  749. end;
  750. function Pow2Int(Exponent: LongInt): LongInt;
  751. begin
  752. Result := 1 shl Exponent;
  753. end;
  754. function Power(const Base, Exponent: Single): Single;
  755. begin
  756. if Exponent = 0.0 then
  757. Result := 1.0
  758. else if (Base = 0.0) and (Exponent > 0.0) then
  759. Result := 0.0
  760. else
  761. Result := Exp(Exponent * Ln(Base));
  762. end;
  763. function Log2Int(X: LongInt): LongInt;
  764. begin
  765. case X of
  766. 1: Result := 0;
  767. 2: Result := 1;
  768. 4: Result := 2;
  769. 8: Result := 3;
  770. 16: Result := 4;
  771. 32: Result := 5;
  772. 64: Result := 6;
  773. 128: Result := 7;
  774. 256: Result := 8;
  775. 512: Result := 9;
  776. 1024: Result := 10;
  777. 2048: Result := 11;
  778. 4096: Result := 12;
  779. 8192: Result := 13;
  780. 16384: Result := 14;
  781. 32768: Result := 15;
  782. 65536: Result := 16;
  783. 131072: Result := 17;
  784. 262144: Result := 18;
  785. 524288: Result := 19;
  786. 1048576: Result := 20;
  787. 2097152: Result := 21;
  788. 4194304: Result := 22;
  789. 8388608: Result := 23;
  790. 16777216: Result := 24;
  791. 33554432: Result := 25;
  792. 67108864: Result := 26;
  793. 134217728: Result := 27;
  794. 268435456: Result := 28;
  795. 536870912: Result := 29;
  796. 1073741824: Result := 30;
  797. else
  798. Result := -1;
  799. end;
  800. end;
  801. function Log2(X: Single): Single;
  802. const
  803. Ln2: Single = 0.6931471;
  804. begin
  805. Result := Ln(X) / Ln2;
  806. end;
  807. function Floor(Value: Single): LongInt;
  808. begin
  809. Result := Trunc(Value);
  810. if Frac(Value) < 0.0 then
  811. Dec(Result);
  812. end;
  813. function Ceil(Value: Single): LongInt;
  814. begin
  815. Result := Trunc(Value);
  816. if Frac(Value) > 0.0 then
  817. Inc(Result);
  818. end;
  819. procedure Switch(var Value: Boolean);
  820. begin
  821. Value := not Value;
  822. end;
  823. function Iff(Condition: Boolean; TruePart, FalsePart: LongInt): LongInt;
  824. begin
  825. if Condition then
  826. Result := TruePart
  827. else
  828. Result := FalsePart;
  829. end;
  830. function IffUnsigned(Condition: Boolean; TruePart, FalsePart: LongWord): LongWord;
  831. begin
  832. if Condition then
  833. Result := TruePart
  834. else
  835. Result := FalsePart;
  836. end;
  837. function Iff(Condition, TruePart, FalsePart: Boolean): Boolean;
  838. begin
  839. if Condition then
  840. Result := TruePart
  841. else
  842. Result := FalsePart;
  843. end;
  844. function Iff(Condition: Boolean; const TruePart, FalsePart: string): string;
  845. begin
  846. if Condition then
  847. Result := TruePart
  848. else
  849. Result := FalsePart;
  850. end;
  851. function Iff(Condition: Boolean; TruePart, FalsePart: Char): Char;
  852. begin
  853. if Condition then
  854. Result := TruePart
  855. else
  856. Result := FalsePart;
  857. end;
  858. function Iff(Condition: Boolean; TruePart, FalsePart: Pointer): Pointer;
  859. begin
  860. if Condition then
  861. Result := TruePart
  862. else
  863. Result := FalsePart;
  864. end;
  865. function Iff(Condition: Boolean; const TruePart, FalsePart: Int64): Int64;
  866. begin
  867. if Condition then
  868. Result := TruePart
  869. else
  870. Result := FalsePart;
  871. end;
  872. function IffFloat(Condition: Boolean; TruePart, FalsePart: Single): Single;
  873. begin
  874. if Condition then
  875. Result := TruePart
  876. else
  877. Result := FalsePart;
  878. end;
  879. procedure SwapValues(var A, B: Byte);
  880. var
  881. Tmp: Byte;
  882. begin
  883. Tmp := A;
  884. A := B;
  885. B := Tmp;
  886. end;
  887. procedure SwapValues(var A, B: Word);
  888. var
  889. Tmp: Word;
  890. begin
  891. Tmp := A;
  892. A := B;
  893. B := Tmp;
  894. end;
  895. procedure SwapValues(var A, B: LongInt);
  896. var
  897. Tmp: LongInt;
  898. begin
  899. Tmp := A;
  900. A := B;
  901. B := Tmp;
  902. end;
  903. procedure SwapValues(var A, B: Single);
  904. var
  905. Tmp: Single;
  906. begin
  907. Tmp := A;
  908. A := B;
  909. B := Tmp;
  910. end;
  911. procedure SwapMin(var Min, Max: LongInt);
  912. var
  913. Tmp: LongInt;
  914. begin
  915. if Min > Max then
  916. begin
  917. Tmp := Min;
  918. Min := Max;
  919. Max := Tmp;
  920. end;
  921. end;
  922. function Min(A, B: LongInt): LongInt;
  923. begin
  924. if A < B then
  925. Result := A
  926. else
  927. Result := B;
  928. end;
  929. function MinFloat(A, B: Single): Single;
  930. begin
  931. if A < B then
  932. Result := A
  933. else
  934. Result := B;
  935. end;
  936. function Max(A, B: LongInt): LongInt;
  937. begin
  938. if A > B then
  939. Result := A
  940. else
  941. Result := B;
  942. end;
  943. function MaxFloat(A, B: Single): Single;
  944. begin
  945. if A > B then
  946. Result := A
  947. else
  948. Result := B;
  949. end;
  950. function MulDiv(Number, Numerator, Denominator: Word): Word;
  951. {$IF Defined(USE_ASM) and (not Defined(USE_INLINE))}
  952. asm
  953. MUL DX
  954. DIV CX
  955. end;
  956. {$ELSE}
  957. begin
  958. Result := Number * Numerator div Denominator;
  959. end;
  960. {$IFEND}
  961. function IsLittleEndian: Boolean;
  962. var
  963. W: Word;
  964. begin
  965. W := $00FF;
  966. Result := PByte(@W)^ = $FF;
  967. end;
  968. function SwapEndianWord(Value: Word): Word;
  969. {$IF Defined(USE_ASM) and (not Defined(USE_INLINE))}
  970. asm
  971. XCHG AH, AL
  972. end;
  973. {$ELSE}
  974. begin
  975. TWordRec(Result).Low := TWordRec(Value).High;
  976. TWordRec(Result).High := TWordRec(Value).Low;
  977. end;
  978. {$IFEND}
  979. procedure SwapEndianWord(P: PWordArray; Count: LongInt);
  980. {$IFDEF USE_ASM}
  981. asm
  982. @Loop:
  983. MOV CX, [EAX]
  984. XCHG CH, CL
  985. MOV [EAX], CX
  986. ADD EAX, 2
  987. DEC EDX
  988. JNZ @Loop
  989. end;
  990. {$ELSE}
  991. var
  992. I: LongInt;
  993. Temp: Word;
  994. begin
  995. for I := 0 to Count - 1 do
  996. begin
  997. Temp := P[I];
  998. TWordRec(P[I]).Low := TWordRec(Temp).High;
  999. TWordRec(P[I]).High := TWordRec(Temp).Low;
  1000. end;
  1001. end;
  1002. {$ENDIF}
  1003. function SwapEndianLongWord(Value: LongWord): LongWord;
  1004. {$IF Defined(USE_ASM) and (not Defined(USE_INLINE))}
  1005. asm
  1006. BSWAP EAX
  1007. end;
  1008. {$ELSE}
  1009. begin
  1010. TLongWordRec(Result).Bytes[0] := TLongWordRec(Value).Bytes[3];
  1011. TLongWordRec(Result).Bytes[1] := TLongWordRec(Value).Bytes[2];
  1012. TLongWordRec(Result).Bytes[2] := TLongWordRec(Value).Bytes[1];
  1013. TLongWordRec(Result).Bytes[3] := TLongWordRec(Value).Bytes[0];
  1014. end;
  1015. {$IFEND}
  1016. procedure SwapEndianLongWord(P: PLongWord; Count: LongInt);
  1017. {$IFDEF USE_ASM}
  1018. asm
  1019. @Loop:
  1020. MOV ECX, [EAX]
  1021. BSWAP ECX
  1022. MOV [EAX], ECX
  1023. ADD EAX, 4
  1024. DEC EDX
  1025. JNZ @Loop
  1026. end;
  1027. {$ELSE}
  1028. var
  1029. I: LongInt;
  1030. Temp: LongWord;
  1031. begin
  1032. for I := 0 to Count - 1 do
  1033. begin
  1034. Temp := PLongWordArray(P)[I];
  1035. TLongWordRec(PLongWordArray(P)[I]).Bytes[0] := TLongWordRec(Temp).Bytes[3];
  1036. TLongWordRec(PLongWordArray(P)[I]).Bytes[1] := TLongWordRec(Temp).Bytes[2];
  1037. TLongWordRec(PLongWordArray(P)[I]).Bytes[2] := TLongWordRec(Temp).Bytes[1];
  1038. TLongWordRec(PLongWordArray(P)[I]).Bytes[3] := TLongWordRec(Temp).Bytes[0];
  1039. end;
  1040. end;
  1041. {$ENDIF}
  1042. type
  1043. TCrcTable = array[Byte] of LongWord;
  1044. var
  1045. CrcTable: TCrcTable;
  1046. procedure InitCrcTable;
  1047. const
  1048. Polynom = $EDB88320;
  1049. var
  1050. I, J: LongInt;
  1051. C: LongWord;
  1052. begin
  1053. for I := 0 to 255 do
  1054. begin
  1055. C := I;
  1056. for J := 0 to 7 do
  1057. begin
  1058. if (C and $01) <> 0 then
  1059. C := Polynom xor (C shr 1)
  1060. else
  1061. C := C shr 1;
  1062. end;
  1063. CrcTable[I] := C;
  1064. end;
  1065. end;
  1066. procedure CalcCrc32(var Crc: LongWord; Data: Pointer; Size: LongInt);
  1067. var
  1068. I: LongInt;
  1069. B: PByte;
  1070. begin
  1071. B := Data;
  1072. for I := 0 to Size - 1 do
  1073. begin
  1074. Crc := (Crc shr 8) xor CrcTable[B^ xor Byte(Crc)];
  1075. Inc(B);
  1076. end
  1077. end;
  1078. procedure FillMemoryByte(Data: Pointer; Size: LongInt; Value: Byte);
  1079. {$IFDEF USE_ASM}
  1080. asm
  1081. PUSH EDI
  1082. MOV EDI, EAX
  1083. MOV EAX, ECX
  1084. MOV AH, AL
  1085. MOV CX, AX
  1086. SHL EAX, 16
  1087. MOV AX, CX
  1088. MOV ECX, EDX
  1089. SAR ECX, 2
  1090. JS @Exit
  1091. REP STOSD
  1092. MOV ECX, EDX
  1093. AND ECX, 3
  1094. REP STOSB
  1095. POP EDI
  1096. @Exit:
  1097. end;
  1098. {$ELSE}
  1099. begin
  1100. FillChar(Data^, Size, Value);
  1101. end;
  1102. {$ENDIF}
  1103. procedure FillMemoryWord(Data: Pointer; Size: LongInt; Value: Word);
  1104. {$IFDEF USE_ASM}
  1105. asm
  1106. PUSH EDI
  1107. PUSH EBX
  1108. MOV EBX, EDX
  1109. MOV EDI, EAX
  1110. MOV EAX, ECX
  1111. MOV CX, AX
  1112. SHL EAX, 16
  1113. MOV AX, CX
  1114. MOV ECX, EDX
  1115. SHR ECX, 2
  1116. JZ @Word
  1117. REP STOSD
  1118. @Word:
  1119. MOV ECX, EBX
  1120. AND ECX, 2
  1121. JZ @Byte
  1122. MOV [EDI], AX
  1123. ADD EDI, 2
  1124. @Byte:
  1125. MOV ECX, EBX
  1126. AND ECX, 1
  1127. JZ @Exit
  1128. MOV [EDI], AL
  1129. @Exit:
  1130. POP EBX
  1131. POP EDI
  1132. end;
  1133. {$ELSE}
  1134. var
  1135. I, V: LongWord;
  1136. begin
  1137. V := Value * $10000 + Value;
  1138. for I := 0 to Size div 4 - 1 do
  1139. PLongWordArray(Data)[I] := V;
  1140. case Size mod 4 of
  1141. 1: PByteArray(Data)[Size - 1] := Lo(Value);
  1142. 2: PWordArray(Data)[Size div 2] := Value;
  1143. 3:
  1144. begin
  1145. PWordArray(Data)[Size div 2 - 1] := Value;
  1146. PByteArray(Data)[Size - 1] := Lo(Value);
  1147. end;
  1148. end;
  1149. end;
  1150. {$ENDIF}
  1151. procedure FillMemoryLongWord(Data: Pointer; Size: LongInt; Value: LongWord);
  1152. {$IFDEF USE_ASM}
  1153. asm
  1154. PUSH EDI
  1155. PUSH EBX
  1156. MOV EBX, EDX
  1157. MOV EDI, EAX
  1158. MOV EAX, ECX
  1159. MOV ECX, EDX
  1160. SHR ECX, 2
  1161. JZ @Word
  1162. REP STOSD
  1163. @Word:
  1164. MOV ECX, EBX
  1165. AND ECX, 2
  1166. JZ @Byte
  1167. MOV [EDI], AX
  1168. ADD EDI, 2
  1169. @Byte:
  1170. MOV ECX, EBX
  1171. AND ECX, 1
  1172. JZ @Exit
  1173. MOV [EDI], AL
  1174. @Exit:
  1175. POP EBX
  1176. POP EDI
  1177. end;
  1178. {$ELSE}
  1179. var
  1180. I: LongInt;
  1181. begin
  1182. for I := 0 to Size div 4 - 1 do
  1183. PLongWordArray(Data)[I] := Value;
  1184. case Size mod 4 of
  1185. 1: PByteArray(Data)[Size - 1] := TLongWordRec(Value).Bytes[0];
  1186. 2: PWordArray(Data)[Size div 2] := TLongWordRec(Value).Words[0];
  1187. 3:
  1188. begin
  1189. PWordArray(Data)[Size div 2 - 1] := TLongWordRec(Value).Words[0];
  1190. PByteArray(Data)[Size - 1] := TLongWordRec(Value).Bytes[0];
  1191. end;
  1192. end;
  1193. end;
  1194. {$ENDIF}
  1195. function GetNumMipMapLevels(Width, Height: LongInt): LongInt;
  1196. begin
  1197. Result := 0;
  1198. if (Width > 0) and (Height > 0) then
  1199. begin
  1200. Result := 1;
  1201. while (Width <> 1) or (Height <> 1) do
  1202. begin
  1203. Width := Width div 2;
  1204. Height := Height div 2;
  1205. if Width < 1 then Width := 1;
  1206. if Height < 1 then Height := 1;
  1207. Inc(Result);
  1208. end;
  1209. end;
  1210. end;
  1211. function GetVolumeLevelCount(Depth, MipMaps: LongInt): LongInt;
  1212. var
  1213. I: LongInt;
  1214. begin
  1215. Result := Depth;
  1216. for I := 1 to MipMaps - 1 do
  1217. Inc(Result, ClampInt(Depth shr I, 1, Depth));
  1218. end;
  1219. function BoundsToRect(X, Y, Width, Height: LongInt): TRect;
  1220. begin
  1221. Result.Left := X;
  1222. Result.Top := Y;
  1223. Result.Right := X + Width;
  1224. Result.Bottom := Y + Height;
  1225. end;
  1226. function BoundsToRect(const R: TRect): TRect;
  1227. begin
  1228. Result.Left := R.Left;
  1229. Result.Top := R.Top;
  1230. Result.Right := R.Left + R.Right;
  1231. Result.Bottom := R.Top + R.Bottom;
  1232. end;
  1233. function RectToBounds(const R: TRect): TRect;
  1234. begin
  1235. Result.Left := R.Left;
  1236. Result.Top := R.Top;
  1237. Result.Right := R.Right - R.Left;
  1238. Result.Bottom := R.Bottom - R.Top;
  1239. end;
  1240. procedure ClipRectBounds(var X, Y, Width, Height: LongInt; const Clip: TRect);
  1241. procedure ClipDim(var AStart, ALength: LongInt; ClipMin, ClipMax: LongInt);
  1242. begin
  1243. if AStart < ClipMin then
  1244. begin
  1245. ALength := ALength - (ClipMin - AStart);
  1246. AStart := ClipMin;
  1247. end;
  1248. if AStart + ALength > ClipMax then ALength := Max(0, ClipMax - AStart);
  1249. end;
  1250. begin
  1251. ClipDim(X, Width, Clip.Left, Clip.Right);
  1252. ClipDim(Y, Height, Clip.Top, Clip.Bottom);
  1253. end;
  1254. procedure ClipCopyBounds(var SrcX, SrcY, Width, Height, DstX, DstY: LongInt; SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect);
  1255. procedure ClipDim(var SrcPos, DstPos, Size: LongInt; SrcClipMax,
  1256. DstClipMin, DstClipMax: LongInt);
  1257. var
  1258. OldDstPos: LongInt;
  1259. Diff: LongInt;
  1260. begin
  1261. OldDstPos := Iff(DstPos < 0, DstPos, 0);
  1262. if DstPos < DstClipMin then
  1263. begin
  1264. Diff := DstClipMin - DstPos;
  1265. Size := Size - Diff;
  1266. if DstPos < SrcPos then
  1267. SrcPos := SrcPos + Diff;
  1268. DstPos := DstClipMin;
  1269. end;
  1270. if SrcPos < 0 then
  1271. begin
  1272. Size := Size + SrcPos - OldDstPos;
  1273. DstPos := DstPos - SrcPos + OldDstPos;
  1274. SrcPos := 0;
  1275. end;
  1276. if SrcPos + Size > SrcClipMax then Size := SrcClipMax - SrcPos;
  1277. if DstPos + Size > DstClipMax then Size := DstClipMax - DstPos;
  1278. end;
  1279. begin
  1280. ClipDim(SrcX, DstX, Width, SrcImageWidth, DstClip.Left, DstClip.Right);
  1281. ClipDim(SrcY, DstY, Height, SrcImageHeight, DstClip.Top, DstClip.Bottom);
  1282. end;
  1283. procedure ClipStretchBounds(var SrcX, SrcY, SrcWidth, SrcHeight, DstX, DstY,
  1284. DstWidth, DstHeight: LongInt; SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect);
  1285. procedure ClipDim(var SrcPos, DstPos, SrcSize, DstSize: LongInt; SrcClipMax,
  1286. DstClipMin, DstClipMax: LongInt);
  1287. var
  1288. OldSize: LongInt;
  1289. Diff: LongInt;
  1290. Scale: Single;
  1291. begin
  1292. Scale := DstSize / SrcSize;
  1293. if DstPos < DstClipMin then
  1294. begin
  1295. Diff := DstClipMin - DstPos;
  1296. DstSize := DstSize - Diff;
  1297. SrcPos := SrcPos + Round(Diff / Scale);
  1298. SrcSize := SrcSize - Round(Diff / Scale);
  1299. DstPos := DstClipMin;
  1300. end;
  1301. if SrcPos < 0 then
  1302. begin
  1303. SrcSize := SrcSize + SrcPos;
  1304. DstPos := DstPos - Round(SrcPos * Scale);
  1305. DstSize := DstSize + Round(SrcPos * Scale);
  1306. SrcPos := 0;
  1307. end;
  1308. if SrcPos + SrcSize > SrcClipMax then
  1309. begin
  1310. OldSize := SrcSize;
  1311. SrcSize := SrcClipMax - SrcPos;
  1312. DstSize := Round(DstSize * (SrcSize / OldSize));
  1313. end;
  1314. if DstPos + DstSize > DstClipMax then
  1315. begin
  1316. OldSize := DstSize;
  1317. DstSize := DstClipMax - DstPos;
  1318. SrcSize := Round(SrcSize * (DstSize / OldSize));
  1319. end;
  1320. end;
  1321. begin
  1322. ClipDim(SrcX, DstX, SrcWidth, DstWidth, SrcImageWidth, DstClip.Left, DstClip.Right);
  1323. ClipDim(SrcY, DstY, SrcHeight, DstHeight, SrcImageHeight, DstClip.Top, DstClip.Bottom);
  1324. end;
  1325. function ScaleRectToRect(const SourceRect, TargetRect: TRect): TRect;
  1326. var
  1327. SourceWidth: LongInt;
  1328. SourceHeight: LongInt;
  1329. TargetWidth: LongInt;
  1330. TargetHeight: LongInt;
  1331. ScaledWidth: LongInt;
  1332. ScaledHeight: LongInt;
  1333. begin
  1334. SourceWidth := SourceRect.Right - SourceRect.Left;
  1335. SourceHeight := SourceRect.Bottom - SourceRect.Top;
  1336. TargetWidth := TargetRect.Right - TargetRect.Left;
  1337. TargetHeight := TargetRect.Bottom - TargetRect.Top;
  1338. if SourceWidth * TargetHeight < SourceHeight * TargetWidth then
  1339. begin
  1340. ScaledWidth := (SourceWidth * TargetHeight) div SourceHeight;
  1341. Result := BoundsToRect(TargetRect.Left + ((TargetWidth - ScaledWidth) div 2),
  1342. TargetRect.Top, ScaledWidth, TargetHeight);
  1343. end
  1344. else
  1345. begin
  1346. ScaledHeight := (SourceHeight * TargetWidth) div SourceWidth;
  1347. Result := BoundsToRect(TargetRect.Left, TargetRect.Top + ((TargetHeight - ScaledHeight) div 2),
  1348. TargetWidth, ScaledHeight);
  1349. end;
  1350. end;
  1351. function RectInRect(const R1, R2: TRect): Boolean;
  1352. begin
  1353. Result:=
  1354. (R1.Left >= R2.Left) and
  1355. (R1.Top >= R2.Top) and
  1356. (R1.Right <= R2.Right) and
  1357. (R1.Bottom <= R2.Bottom);
  1358. end;
  1359. function RectIntersects(const R1, R2: TRect): Boolean;
  1360. begin
  1361. Result :=
  1362. not (R1.Left > R2.Right) and
  1363. not (R1.Top > R2.Bottom) and
  1364. not (R1.Right < R2.Left) and
  1365. not (R1.Bottom < R2.Top);
  1366. end;
  1367. function FormatExceptMsg(const Msg: string; const Args: array of const): string;
  1368. begin
  1369. Result := Format(Msg + SLineBreak + 'Message: ' + GetExceptObject.Message, Args);
  1370. end;
  1371. procedure DebugMsg(const Msg: string; const Args: array of const);
  1372. var
  1373. FmtMsg: string;
  1374. begin
  1375. FmtMsg := Format(Msg, Args);
  1376. {$IFDEF MSWINDOWS}
  1377. if IsConsole then
  1378. WriteLn('DebugMsg: ' + FmtMsg)
  1379. else
  1380. MessageBox(GetActiveWindow, PChar(FmtMsg), 'DebugMsg', MB_OK);
  1381. {$ENDIF}
  1382. {$IFDEF UNIX}
  1383. WriteLn('DebugMsg: ' + FmtMsg);
  1384. {$ENDIF}
  1385. {$IFDEF MSDOS}
  1386. WriteLn('DebugMsg: ' + FmtMsg);
  1387. {$ENDIF}
  1388. end;
  1389. initialization
  1390. InitCrcTable;
  1391. {$IFDEF MSWINDOWS}
  1392. QueryPerformanceFrequency(PerfFrequency);
  1393. InvPerfFrequency := 1.0 / PerfFrequency;
  1394. {$ENDIF}
  1395. {$IFDEF MSDOS}
  1396. // reset PIT
  1397. asm
  1398. MOV EAX, $34
  1399. OUT $43, AL
  1400. XOR EAX, EAX
  1401. OUT $40, AL
  1402. OUT $40, AL
  1403. end;
  1404. {$ENDIF}
  1405. {
  1406. File Notes:
  1407. -- TODOS ----------------------------------------------------
  1408. - nothing now
  1409. -- 0.23 Changes/Bug Fixes -----------------------------------
  1410. - Added RectInRect and RectIntersects functions
  1411. - Added some string utils: StrToken, StrTokenEnd, PosEx, PosNoCase.
  1412. - Moved BuildFileList here from DemoUtils.
  1413. -- 0.21 Changes/Bug Fixes -----------------------------------
  1414. - Moved GetVolumeLevelCount from ImagingDds here.
  1415. - Renamed FillMemory to FillMemoryByte to avoid name collision in C++ Builder.
  1416. - Added Iff function for Char, Pointer, and Int64 types.
  1417. - Added IsLittleEndian function.
  1418. - Added array types for TWordRec, TLongWordRec, and TInt64Rec.
  1419. - Added MatchFileNameMask function.
  1420. -- 0.19 Changes/Bug Fixes -----------------------------------
  1421. - added ScaleRectToRect (thanks to Paul Michell)
  1422. - added BoundsToRect, ClipBounds, ClipCopyBounds, ClipStretchBounds functions
  1423. - added MulDiv function
  1424. - FreeAndNil is not inline anymore - caused AV in one program
  1425. -- 0.17 Changes/Bug Fixes -----------------------------------
  1426. - GetAppExe didn't return absolute path in FreeBSD, fixed
  1427. - added debug message output
  1428. - fixed Unix compatibility issues (thanks to Ales Katona).
  1429. Imaging now compiles in FreeBSD and maybe in other Unixes as well.
  1430. -- 0.15 Changes/Bug Fixes -----------------------------------
  1431. - added some new utility functions
  1432. -- 0.13 Changes/Bug Fixes -----------------------------------
  1433. - added many new utility functions
  1434. - minor change in SwapEndian to avoid range check error
  1435. }
  1436. end.