Программа для прослушивания журнала АРК Томск http://blindage.org/?p=6627
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

synautil.pas 56KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065
  1. {==============================================================================|
  2. | Project : Ararat Synapse | 004.015.000 |
  3. |==============================================================================|
  4. | Content: support procedures and functions |
  5. |==============================================================================|
  6. | Copyright (c)1999-2012, Lukas Gebauer |
  7. | All rights reserved. |
  8. | |
  9. | Redistribution and use in source and binary forms, with or without |
  10. | modification, are permitted provided that the following conditions are met: |
  11. | |
  12. | Redistributions of source code must retain the above copyright notice, this |
  13. | list of conditions and the following disclaimer. |
  14. | |
  15. | Redistributions in binary form must reproduce the above copyright notice, |
  16. | this list of conditions and the following disclaimer in the documentation |
  17. | and/or other materials provided with the distribution. |
  18. | |
  19. | Neither the name of Lukas Gebauer nor the names of its contributors may |
  20. | be used to endorse or promote products derived from this software without |
  21. | specific prior written permission. |
  22. | |
  23. | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
  24. | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
  25. | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
  26. | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
  27. | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
  28. | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
  29. | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
  30. | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
  31. | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
  32. | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
  33. | DAMAGE. |
  34. |==============================================================================|
  35. | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
  36. | Portions created by Lukas Gebauer are Copyright (c) 1999-2012. |
  37. | Portions created by Hernan Sanchez are Copyright (c) 2000. |
  38. | Portions created by Petr Fejfar are Copyright (c)2011-2012. |
  39. | All Rights Reserved. |
  40. |==============================================================================|
  41. | Contributor(s): |
  42. | Hernan Sanchez (hernan.sanchez@iname.com) |
  43. |==============================================================================|
  44. | History: see HISTORY.HTM from distribution package |
  45. | (Found at URL: http://www.ararat.cz/synapse/) |
  46. |==============================================================================}
  47. {:@abstract(Support procedures and functions)}
  48. {$IFDEF FPC}
  49. {$MODE DELPHI}
  50. {$ENDIF}
  51. {$Q-}
  52. {$R-}
  53. {$H+}
  54. //old Delphi does not have MSWINDOWS define.
  55. {$IFDEF WIN32}
  56. {$IFNDEF MSWINDOWS}
  57. {$DEFINE MSWINDOWS}
  58. {$ENDIF}
  59. {$ENDIF}
  60. {$IFDEF UNICODE}
  61. {$WARN IMPLICIT_STRING_CAST OFF}
  62. {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
  63. {$WARN SUSPICIOUS_TYPECAST OFF}
  64. {$ENDIF}
  65. unit synautil;
  66. interface
  67. uses
  68. {$IFDEF MSWINDOWS}
  69. Windows,
  70. {$ELSE}
  71. {$IFDEF FPC}
  72. UnixUtil, Unix, BaseUnix,
  73. {$ELSE}
  74. Libc,
  75. {$ENDIF}
  76. {$ENDIF}
  77. {$IFDEF CIL}
  78. System.IO,
  79. {$ENDIF}
  80. SysUtils, Classes, SynaFpc;
  81. {$IFDEF VER100}
  82. type
  83. int64 = integer;
  84. {$ENDIF}
  85. {:Return your timezone bias from UTC time in minutes.}
  86. function TimeZoneBias: integer;
  87. {:Return your timezone bias from UTC time in string representation like "+0200".}
  88. function TimeZone: string;
  89. {:Returns current time in format defined in RFC-822. Useful for SMTP messages,
  90. but other protocols use this time format as well. Results contains the timezone
  91. specification. Four digit year is used to break any Y2K concerns. (Example
  92. 'Fri, 15 Oct 1999 21:14:56 +0200')}
  93. function Rfc822DateTime(t: TDateTime): string;
  94. {:Returns date and time in format defined in C compilers in format "mmm dd hh:nn:ss"}
  95. function CDateTime(t: TDateTime): string;
  96. {:Returns date and time in format defined in format 'yymmdd hhnnss'}
  97. function SimpleDateTime(t: TDateTime): string;
  98. {:Returns date and time in format defined in ANSI C compilers in format
  99. "ddd mmm d hh:nn:ss yyyy" }
  100. function AnsiCDateTime(t: TDateTime): string;
  101. {:Decode three-letter string with name of month to their month number. If string
  102. not match any month name, then is returned 0. For parsing are used predefined
  103. names for English, French and German and names from system locale too.}
  104. function GetMonthNumber(Value: String): integer;
  105. {:Return decoded time from given string. Time must be witch separator ':'. You
  106. can use "hh:mm" or "hh:mm:ss".}
  107. function GetTimeFromStr(Value: string): TDateTime;
  108. {:Decode string in format "m-d-y" to TDateTime type.}
  109. function GetDateMDYFromStr(Value: string): TDateTime;
  110. {:Decode various string representations of date and time to Tdatetime type.
  111. This function do all timezone corrections too! This function can decode lot of
  112. formats like:
  113. @longcode(#
  114. ddd, d mmm yyyy hh:mm:ss
  115. ddd, d mmm yy hh:mm:ss
  116. ddd, mmm d yyyy hh:mm:ss
  117. ddd mmm dd hh:mm:ss yyyy #)
  118. and more with lot of modifications, include:
  119. @longcode(#
  120. Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123
  121. Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036
  122. Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() Format
  123. #)
  124. Timezone corrections known lot of symbolic timezone names (like CEST, EDT, etc.)
  125. or numeric representation (like +0200). By convention defined in RFC timezone
  126. +0000 is GMT and -0000 is current your system timezone.}
  127. function DecodeRfcDateTime(Value: string): TDateTime;
  128. {:Return current system date and time in UTC timezone.}
  129. function GetUTTime: TDateTime;
  130. {:Set Newdt as current system date and time in UTC timezone. This function work
  131. only if you have administrator rights!}
  132. function SetUTTime(Newdt: TDateTime): Boolean;
  133. {:Return current value of system timer with precizion 1 millisecond. Good for
  134. measure time difference.}
  135. function GetTick: LongWord;
  136. {:Return difference between two timestamps. It working fine only for differences
  137. smaller then maxint. (difference must be smaller then 24 days.)}
  138. function TickDelta(TickOld, TickNew: LongWord): LongWord;
  139. {:Return two characters, which ordinal values represents the value in byte
  140. format. (High-endian)}
  141. function CodeInt(Value: Word): Ansistring;
  142. {:Decodes two characters located at "Index" offset position of the "Value"
  143. string to Word values.}
  144. function DecodeInt(const Value: Ansistring; Index: Integer): Word;
  145. {:Return four characters, which ordinal values represents the value in byte
  146. format. (High-endian)}
  147. function CodeLongInt(Value: LongInt): Ansistring;
  148. {:Decodes four characters located at "Index" offset position of the "Value"
  149. string to LongInt values.}
  150. function DecodeLongInt(const Value: Ansistring; Index: Integer): LongInt;
  151. {:Dump binary buffer stored in a string to a result string.}
  152. function DumpStr(const Buffer: Ansistring): string;
  153. {:Dump binary buffer stored in a string to a result string. All bytes with code
  154. of character is written as character, not as hexadecimal value.}
  155. function DumpExStr(const Buffer: Ansistring): string;
  156. {:Dump binary buffer stored in a string to a file with DumpFile filename.}
  157. procedure Dump(const Buffer: AnsiString; DumpFile: string);
  158. {:Dump binary buffer stored in a string to a file with DumpFile filename. All
  159. bytes with code of character is written as character, not as hexadecimal value.}
  160. procedure DumpEx(const Buffer: AnsiString; DumpFile: string);
  161. {:Like TrimLeft, but remove only spaces, not control characters!}
  162. function TrimSPLeft(const S: string): string;
  163. {:Like TrimRight, but remove only spaces, not control characters!}
  164. function TrimSPRight(const S: string): string;
  165. {:Like Trim, but remove only spaces, not control characters!}
  166. function TrimSP(const S: string): string;
  167. {:Returns a portion of the "Value" string located to the left of the "Delimiter"
  168. string. If a delimiter is not found, results is original string.}
  169. function SeparateLeft(const Value, Delimiter: string): string;
  170. {:Returns the portion of the "Value" string located to the right of the
  171. "Delimiter" string. If a delimiter is not found, results is original string.}
  172. function SeparateRight(const Value, Delimiter: string): string;
  173. {:Returns parameter value from string in format:
  174. parameter1="value1"; parameter2=value2}
  175. function GetParameter(const Value, Parameter: string): string;
  176. {:parse value string with elements differed by Delimiter into stringlist.}
  177. procedure ParseParametersEx(Value, Delimiter: string; const Parameters: TStrings);
  178. {:parse value string with elements differed by ';' into stringlist.}
  179. procedure ParseParameters(Value: string; const Parameters: TStrings);
  180. {:Index of string in stringlist with same beginning as Value is returned.}
  181. function IndexByBegin(Value: string; const List: TStrings): integer;
  182. {:Returns only the e-mail portion of an address from the full address format.
  183. i.e. returns 'nobody@@somewhere.com' from '"someone" <nobody@@somewhere.com>'}
  184. function GetEmailAddr(const Value: string): string;
  185. {:Returns only the description part from a full address format. i.e. returns
  186. 'someone' from '"someone" <nobody@@somewhere.com>'}
  187. function GetEmailDesc(Value: string): string;
  188. {:Returns a string with hexadecimal digits representing the corresponding values
  189. of the bytes found in "Value" string.}
  190. function StrToHex(const Value: Ansistring): string;
  191. {:Returns a string of binary "Digits" representing "Value".}
  192. function IntToBin(Value: Integer; Digits: Byte): string;
  193. {:Returns an integer equivalent of the binary string in "Value".
  194. (i.e. ('10001010') returns 138)}
  195. function BinToInt(const Value: string): Integer;
  196. {:Parses a URL to its various components.}
  197. function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path,
  198. Para: string): string;
  199. {:Replaces all "Search" string values found within "Value" string, with the
  200. "Replace" string value.}
  201. function ReplaceString(Value, Search, Replace: AnsiString): AnsiString;
  202. {:It is like RPos, but search is from specified possition.}
  203. function RPosEx(const Sub, Value: string; From: integer): Integer;
  204. {:It is like POS function, but from right side of Value string.}
  205. function RPos(const Sub, Value: String): Integer;
  206. {:Like @link(fetch), but working with binary strings, not with text.}
  207. function FetchBin(var Value: string; const Delimiter: string): string;
  208. {:Fetch string from left of Value string.}
  209. function Fetch(var Value: string; const Delimiter: string): string;
  210. {:Fetch string from left of Value string. This function ignore delimitesr inside
  211. quotations.}
  212. function FetchEx(var Value: string; const Delimiter, Quotation: string): string;
  213. {:If string is binary string (contains non-printable characters), then is
  214. returned true.}
  215. function IsBinaryString(const Value: AnsiString): Boolean;
  216. {:return position of string terminator in string. If terminator found, then is
  217. returned in terminator parameter.
  218. Possible line terminators are: CRLF, LFCR, CR, LF}
  219. function PosCRLF(const Value: AnsiString; var Terminator: AnsiString): integer;
  220. {:Delete empty strings from end of stringlist.}
  221. Procedure StringsTrim(const value: TStrings);
  222. {:Like Pos function, buf from given string possition.}
  223. function PosFrom(const SubStr, Value: String; From: integer): integer;
  224. {$IFNDEF CIL}
  225. {:Increase pointer by value.}
  226. function IncPoint(const p: pointer; Value: integer): pointer;
  227. {$ENDIF}
  228. {:Get string between PairBegin and PairEnd. This function respect nesting.
  229. For example:
  230. @longcode(#
  231. Value is: 'Hi! (hello(yes!))'
  232. pairbegin is: '('
  233. pairend is: ')'
  234. In this case result is: 'hello(yes!)'#)}
  235. function GetBetween(const PairBegin, PairEnd, Value: string): string;
  236. {:Return count of Chr in Value string.}
  237. function CountOfChar(const Value: string; Chr: char): integer;
  238. {:Remove quotation from Value string. If Value is not quoted, then return same
  239. string without any modification. }
  240. function UnquoteStr(const Value: string; Quote: Char): string;
  241. {:Quote Value string. If Value contains some Quote chars, then it is doubled.}
  242. function QuoteStr(const Value: string; Quote: Char): string;
  243. {:Convert lines in stringlist from 'name: value' form to 'name=value' form.}
  244. procedure HeadersToList(const Value: TStrings);
  245. {:Convert lines in stringlist from 'name=value' form to 'name: value' form.}
  246. procedure ListToHeaders(const Value: TStrings);
  247. {:swap bytes in integer.}
  248. function SwapBytes(Value: integer): integer;
  249. {:read string with requested length form stream.}
  250. function ReadStrFromStream(const Stream: TStream; len: integer): AnsiString;
  251. {:write string to stream.}
  252. procedure WriteStrToStream(const Stream: TStream; Value: AnsiString);
  253. {:Return filename of new temporary file in Dir (if empty, then default temporary
  254. directory is used) and with optional filename prefix.}
  255. function GetTempFile(const Dir, prefix: AnsiString): AnsiString;
  256. {:Return padded string. If length is greater, string is truncated. If length is
  257. smaller, string is padded by Pad character.}
  258. function PadString(const Value: AnsiString; len: integer; Pad: AnsiChar): AnsiString;
  259. {:XOR each byte in the strings}
  260. function XorString(Indata1, Indata2: AnsiString): AnsiString;
  261. {:Read header from "Value" stringlist beginning at "Index" position. If header
  262. is Splitted into multiple lines, then this procedure de-split it into one line.}
  263. function NormalizeHeader(Value: TStrings; var Index: Integer): string;
  264. {pf}
  265. {:Search for one of line terminators CR, LF or NUL. Return position of the
  266. line beginning and length of text.}
  267. procedure SearchForLineBreak(var APtr:PANSIChar; AEtx:PANSIChar; out ABol:PANSIChar; out ALength:integer);
  268. {:Skip both line terminators CR LF (if any). Move APtr position forward.}
  269. procedure SkipLineBreak(var APtr:PANSIChar; AEtx:PANSIChar);
  270. {:Skip all blank lines in a buffer starting at APtr and move APtr position forward.}
  271. procedure SkipNullLines (var APtr:PANSIChar; AEtx:PANSIChar);
  272. {:Copy all lines from a buffer starting at APtr to ALines until empty line
  273. or end of the buffer is reached. Move APtr position forward).}
  274. procedure CopyLinesFromStreamUntilNullLine(var APtr:PANSIChar; AEtx:PANSIChar; ALines:TStrings);
  275. {:Copy all lines from a buffer starting at APtr to ALines until ABoundary
  276. or end of the buffer is reached. Move APtr position forward).}
  277. procedure CopyLinesFromStreamUntilBoundary(var APtr:PANSIChar; AEtx:PANSIChar; ALines:TStrings; const ABoundary:ANSIString);
  278. {:Search ABoundary in a buffer starting at APtr.
  279. Return beginning of the ABoundary. Move APtr forward behind a trailing CRLF if any).}
  280. function SearchForBoundary (var APtr:PANSIChar; AEtx:PANSIChar; const ABoundary:ANSIString): PANSIChar;
  281. {:Compare a text at position ABOL with ABoundary and return position behind the
  282. match (including a trailing CRLF if any).}
  283. function MatchBoundary (ABOL,AETX:PANSIChar; const ABoundary:ANSIString): PANSIChar;
  284. {:Compare a text at position ABOL with ABoundary + the last boundary suffix
  285. and return position behind the match (including a trailing CRLF if any).}
  286. function MatchLastBoundary (ABOL,AETX:PANSIChar; const ABoundary:ANSIString): PANSIChar;
  287. {:Copy data from a buffer starting at position APtr and delimited by AEtx
  288. position into ANSIString.}
  289. function BuildStringFromBuffer (AStx,AEtx:PANSIChar): ANSIString;
  290. {/pf}
  291. var
  292. {:can be used for your own months strings for @link(getmonthnumber)}
  293. CustomMonthNames: array[1..12] of string;
  294. implementation
  295. {==============================================================================}
  296. const
  297. MyDayNames: array[1..7] of AnsiString =
  298. ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
  299. var
  300. MyMonthNames: array[0..6, 1..12] of String =
  301. (
  302. ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', //rewrited by system locales
  303. 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'),
  304. ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', //English
  305. 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'),
  306. ('jan', 'fév', 'mar', 'avr', 'mai', 'jun', //French
  307. 'jul', 'aoû', 'sep', 'oct', 'nov', 'déc'),
  308. ('jan', 'fev', 'mar', 'avr', 'mai', 'jun', //French#2
  309. 'jul', 'aou', 'sep', 'oct', 'nov', 'dec'),
  310. ('Jan', 'Feb', 'Mar', 'Apr', 'Mai', 'Jun', //German
  311. 'Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez'),
  312. ('Jan', 'Feb', 'Mär', 'Apr', 'Mai', 'Jun', //German#2
  313. 'Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez'),
  314. ('Led', 'Úno', 'Bøe', 'Dub', 'Kvì', 'Èen', //Czech
  315. 'Èec', 'Srp', 'Záø', 'Øíj', 'Lis', 'Pro')
  316. );
  317. {==============================================================================}
  318. function TimeZoneBias: integer;
  319. {$IFNDEF MSWINDOWS}
  320. {$IFNDEF FPC}
  321. var
  322. t: TTime_T;
  323. UT: TUnixTime;
  324. begin
  325. __time(@T);
  326. localtime_r(@T, UT);
  327. Result := ut.__tm_gmtoff div 60;
  328. {$ELSE}
  329. begin
  330. Result := TZSeconds div 60;
  331. {$ENDIF}
  332. {$ELSE}
  333. var
  334. zoneinfo: TTimeZoneInformation;
  335. bias: Integer;
  336. begin
  337. case GetTimeZoneInformation(Zoneinfo) of
  338. 2:
  339. bias := zoneinfo.Bias + zoneinfo.DaylightBias;
  340. 1:
  341. bias := zoneinfo.Bias + zoneinfo.StandardBias;
  342. else
  343. bias := zoneinfo.Bias;
  344. end;
  345. Result := bias * (-1);
  346. {$ENDIF}
  347. end;
  348. {==============================================================================}
  349. function TimeZone: string;
  350. var
  351. bias: Integer;
  352. h, m: Integer;
  353. begin
  354. bias := TimeZoneBias;
  355. if bias >= 0 then
  356. Result := '+'
  357. else
  358. Result := '-';
  359. bias := Abs(bias);
  360. h := bias div 60;
  361. m := bias mod 60;
  362. Result := Result + Format('%.2d%.2d', [h, m]);
  363. end;
  364. {==============================================================================}
  365. function Rfc822DateTime(t: TDateTime): string;
  366. var
  367. wYear, wMonth, wDay: word;
  368. begin
  369. DecodeDate(t, wYear, wMonth, wDay);
  370. Result := Format('%s, %d %s %s %s', [MyDayNames[DayOfWeek(t)], wDay,
  371. MyMonthNames[1, wMonth], FormatDateTime('yyyy hh":"nn":"ss', t), TimeZone]);
  372. end;
  373. {==============================================================================}
  374. function CDateTime(t: TDateTime): string;
  375. var
  376. wYear, wMonth, wDay: word;
  377. begin
  378. DecodeDate(t, wYear, wMonth, wDay);
  379. Result:= Format('%s %2d %s', [MyMonthNames[1, wMonth], wDay,
  380. FormatDateTime('hh":"nn":"ss', t)]);
  381. end;
  382. {==============================================================================}
  383. function SimpleDateTime(t: TDateTime): string;
  384. begin
  385. Result := FormatDateTime('yymmdd hhnnss', t);
  386. end;
  387. {==============================================================================}
  388. function AnsiCDateTime(t: TDateTime): string;
  389. var
  390. wYear, wMonth, wDay: word;
  391. begin
  392. DecodeDate(t, wYear, wMonth, wDay);
  393. Result := Format('%s %s %d %s', [MyDayNames[DayOfWeek(t)], MyMonthNames[1, wMonth],
  394. wDay, FormatDateTime('hh":"nn":"ss yyyy ', t)]);
  395. end;
  396. {==============================================================================}
  397. function DecodeTimeZone(Value: string; var Zone: integer): Boolean;
  398. var
  399. x: integer;
  400. zh, zm: integer;
  401. s: string;
  402. begin
  403. Result := false;
  404. s := Value;
  405. if (Pos('+', s) = 1) or (Pos('-',s) = 1) then
  406. begin
  407. if s = '-0000' then
  408. Zone := TimeZoneBias
  409. else
  410. if Length(s) > 4 then
  411. begin
  412. zh := StrToIntdef(s[2] + s[3], 0);
  413. zm := StrToIntdef(s[4] + s[5], 0);
  414. zone := zh * 60 + zm;
  415. if s[1] = '-' then
  416. zone := zone * (-1);
  417. end;
  418. Result := True;
  419. end
  420. else
  421. begin
  422. x := 32767;
  423. if s = 'NZDT' then x := 13;
  424. if s = 'IDLE' then x := 12;
  425. if s = 'NZST' then x := 12;
  426. if s = 'NZT' then x := 12;
  427. if s = 'EADT' then x := 11;
  428. if s = 'GST' then x := 10;
  429. if s = 'JST' then x := 9;
  430. if s = 'CCT' then x := 8;
  431. if s = 'WADT' then x := 8;
  432. if s = 'WAST' then x := 7;
  433. if s = 'ZP6' then x := 6;
  434. if s = 'ZP5' then x := 5;
  435. if s = 'ZP4' then x := 4;
  436. if s = 'BT' then x := 3;
  437. if s = 'EET' then x := 2;
  438. if s = 'MEST' then x := 2;
  439. if s = 'MESZ' then x := 2;
  440. if s = 'SST' then x := 2;
  441. if s = 'FST' then x := 2;
  442. if s = 'CEST' then x := 2;
  443. if s = 'CET' then x := 1;
  444. if s = 'FWT' then x := 1;
  445. if s = 'MET' then x := 1;
  446. if s = 'MEWT' then x := 1;
  447. if s = 'SWT' then x := 1;
  448. if s = 'UT' then x := 0;
  449. if s = 'UTC' then x := 0;
  450. if s = 'GMT' then x := 0;
  451. if s = 'WET' then x := 0;
  452. if s = 'WAT' then x := -1;
  453. if s = 'BST' then x := -1;
  454. if s = 'AT' then x := -2;
  455. if s = 'ADT' then x := -3;
  456. if s = 'AST' then x := -4;
  457. if s = 'EDT' then x := -4;
  458. if s = 'EST' then x := -5;
  459. if s = 'CDT' then x := -5;
  460. if s = 'CST' then x := -6;
  461. if s = 'MDT' then x := -6;
  462. if s = 'MST' then x := -7;
  463. if s = 'PDT' then x := -7;
  464. if s = 'PST' then x := -8;
  465. if s = 'YDT' then x := -8;
  466. if s = 'YST' then x := -9;
  467. if s = 'HDT' then x := -9;
  468. if s = 'AHST' then x := -10;
  469. if s = 'CAT' then x := -10;
  470. if s = 'HST' then x := -10;
  471. if s = 'EAST' then x := -10;
  472. if s = 'NT' then x := -11;
  473. if s = 'IDLW' then x := -12;
  474. if x <> 32767 then
  475. begin
  476. zone := x * 60;
  477. Result := True;
  478. end;
  479. end;
  480. end;
  481. {==============================================================================}
  482. function GetMonthNumber(Value: String): integer;
  483. var
  484. n: integer;
  485. function TestMonth(Value: String; Index: Integer): Boolean;
  486. var
  487. n: integer;
  488. begin
  489. Result := False;
  490. for n := 0 to 6 do
  491. if Value = AnsiUppercase(MyMonthNames[n, Index]) then
  492. begin
  493. Result := True;
  494. Break;
  495. end;
  496. end;
  497. begin
  498. Result := 0;
  499. Value := AnsiUppercase(Value);
  500. for n := 1 to 12 do
  501. if TestMonth(Value, n) or (Value = AnsiUppercase(CustomMonthNames[n])) then
  502. begin
  503. Result := n;
  504. Break;
  505. end;
  506. end;
  507. {==============================================================================}
  508. function GetTimeFromStr(Value: string): TDateTime;
  509. var
  510. x: integer;
  511. begin
  512. x := rpos(':', Value);
  513. if (x > 0) and ((Length(Value) - x) > 2) then
  514. Value := Copy(Value, 1, x + 2);
  515. Value := ReplaceString(Value, ':', TimeSeparator);
  516. Result := -1;
  517. try
  518. Result := StrToTime(Value);
  519. except
  520. on Exception do ;
  521. end;
  522. end;
  523. {==============================================================================}
  524. function GetDateMDYFromStr(Value: string): TDateTime;
  525. var
  526. wYear, wMonth, wDay: word;
  527. s: string;
  528. begin
  529. Result := 0;
  530. s := Fetch(Value, '-');
  531. wMonth := StrToIntDef(s, 12);
  532. s := Fetch(Value, '-');
  533. wDay := StrToIntDef(s, 30);
  534. wYear := StrToIntDef(Value, 1899);
  535. if wYear < 1000 then
  536. if (wYear > 99) then
  537. wYear := wYear + 1900
  538. else
  539. if wYear > 50 then
  540. wYear := wYear + 1900
  541. else
  542. wYear := wYear + 2000;
  543. try
  544. Result := EncodeDate(wYear, wMonth, wDay);
  545. except
  546. on Exception do ;
  547. end;
  548. end;
  549. {==============================================================================}
  550. function DecodeRfcDateTime(Value: string): TDateTime;
  551. var
  552. day, month, year: Word;
  553. zone: integer;
  554. x, y: integer;
  555. s: string;
  556. t: TDateTime;
  557. begin
  558. // ddd, d mmm yyyy hh:mm:ss
  559. // ddd, d mmm yy hh:mm:ss
  560. // ddd, mmm d yyyy hh:mm:ss
  561. // ddd mmm dd hh:mm:ss yyyy
  562. // Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123
  563. // Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036
  564. // Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() Format
  565. Result := 0;
  566. if Value = '' then
  567. Exit;
  568. day := 0;
  569. month := 0;
  570. year := 0;
  571. zone := 0;
  572. Value := ReplaceString(Value, ' -', ' #');
  573. Value := ReplaceString(Value, '-', ' ');
  574. Value := ReplaceString(Value, ' #', ' -');
  575. while Value <> '' do
  576. begin
  577. s := Fetch(Value, ' ');
  578. s := uppercase(s);
  579. // timezone
  580. if DecodetimeZone(s, x) then
  581. begin
  582. zone := x;
  583. continue;
  584. end;
  585. x := StrToIntDef(s, 0);
  586. // day or year
  587. if x > 0 then
  588. if (x < 32) and (day = 0) then
  589. begin
  590. day := x;
  591. continue;
  592. end
  593. else
  594. begin
  595. if (year = 0) and ((month > 0) or (x > 12)) then
  596. begin
  597. year := x;
  598. if year < 32 then
  599. year := year + 2000;
  600. if year < 1000 then
  601. year := year + 1900;
  602. continue;
  603. end;
  604. end;
  605. // time
  606. if rpos(':', s) > Pos(':', s) then
  607. begin
  608. t := GetTimeFromStr(s);
  609. if t <> -1 then
  610. Result := t;
  611. continue;
  612. end;
  613. //timezone daylight saving time
  614. if s = 'DST' then
  615. begin
  616. zone := zone + 60;
  617. continue;
  618. end;
  619. // month
  620. y := GetMonthNumber(s);
  621. if (y > 0) and (month = 0) then
  622. month := y;
  623. end;
  624. if year = 0 then
  625. year := 1980;
  626. if month < 1 then
  627. month := 1;
  628. if month > 12 then
  629. month := 12;
  630. if day < 1 then
  631. day := 1;
  632. x := MonthDays[IsLeapYear(year), month];
  633. if day > x then
  634. day := x;
  635. Result := Result + Encodedate(year, month, day);
  636. zone := zone - TimeZoneBias;
  637. x := zone div 1440;
  638. Result := Result - x;
  639. zone := zone mod 1440;
  640. t := EncodeTime(Abs(zone) div 60, Abs(zone) mod 60, 0, 0);
  641. if zone < 0 then
  642. t := 0 - t;
  643. Result := Result - t;
  644. end;
  645. {==============================================================================}
  646. function GetUTTime: TDateTime;
  647. {$IFDEF MSWINDOWS}
  648. {$IFNDEF FPC}
  649. var
  650. st: TSystemTime;
  651. begin
  652. GetSystemTime(st);
  653. result := SystemTimeToDateTime(st);
  654. {$ELSE}
  655. var
  656. st: SysUtils.TSystemTime;
  657. stw: Windows.TSystemTime;
  658. begin
  659. GetSystemTime(stw);
  660. st.Year := stw.wYear;
  661. st.Month := stw.wMonth;
  662. st.Day := stw.wDay;
  663. st.Hour := stw.wHour;
  664. st.Minute := stw.wMinute;
  665. st.Second := stw.wSecond;
  666. st.Millisecond := stw.wMilliseconds;
  667. result := SystemTimeToDateTime(st);
  668. {$ENDIF}
  669. {$ELSE}
  670. {$IFNDEF FPC}
  671. var
  672. TV: TTimeVal;
  673. begin
  674. gettimeofday(TV, nil);
  675. Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400;
  676. {$ELSE}
  677. var
  678. TV: TimeVal;
  679. begin
  680. fpgettimeofday(@TV, nil);
  681. Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400;
  682. {$ENDIF}
  683. {$ENDIF}
  684. end;
  685. {==============================================================================}
  686. function SetUTTime(Newdt: TDateTime): Boolean;
  687. {$IFDEF MSWINDOWS}
  688. {$IFNDEF FPC}
  689. var
  690. st: TSystemTime;
  691. begin
  692. DateTimeToSystemTime(newdt,st);
  693. Result := SetSystemTime(st);
  694. {$ELSE}
  695. var
  696. st: SysUtils.TSystemTime;
  697. stw: Windows.TSystemTime;
  698. begin
  699. DateTimeToSystemTime(newdt,st);
  700. stw.wYear := st.Year;
  701. stw.wMonth := st.Month;
  702. stw.wDay := st.Day;
  703. stw.wHour := st.Hour;
  704. stw.wMinute := st.Minute;
  705. stw.wSecond := st.Second;
  706. stw.wMilliseconds := st.Millisecond;
  707. Result := SetSystemTime(stw);
  708. {$ENDIF}
  709. {$ELSE}
  710. {$IFNDEF FPC}
  711. var
  712. TV: TTimeVal;
  713. d: double;
  714. TZ: Ttimezone;
  715. PZ: PTimeZone;
  716. begin
  717. TZ.tz_minuteswest := 0;
  718. TZ.tz_dsttime := 0;
  719. PZ := @TZ;
  720. gettimeofday(TV, PZ);
  721. d := (newdt - UnixDateDelta) * 86400;
  722. TV.tv_sec := trunc(d);
  723. TV.tv_usec := trunc(frac(d) * 1000000);
  724. Result := settimeofday(TV, TZ) <> -1;
  725. {$ELSE}
  726. var
  727. TV: TimeVal;
  728. d: double;
  729. begin
  730. d := (newdt - UnixDateDelta) * 86400;
  731. TV.tv_sec := trunc(d);
  732. TV.tv_usec := trunc(frac(d) * 1000000);
  733. Result := fpsettimeofday(@TV, nil) <> -1;
  734. {$ENDIF}
  735. {$ENDIF}
  736. end;
  737. {==============================================================================}
  738. {$IFNDEF MSWINDOWS}
  739. function GetTick: LongWord;
  740. var
  741. Stamp: TTimeStamp;
  742. begin
  743. Stamp := DateTimeToTimeStamp(Now);
  744. Result := Stamp.Time;
  745. end;
  746. {$ELSE}
  747. function GetTick: LongWord;
  748. var
  749. tick, freq: TLargeInteger;
  750. {$IFDEF VER100}
  751. x: TLargeInteger;
  752. {$ENDIF}
  753. begin
  754. if Windows.QueryPerformanceFrequency(freq) then
  755. begin
  756. Windows.QueryPerformanceCounter(tick);
  757. {$IFDEF VER100}
  758. x.QuadPart := (tick.QuadPart / freq.QuadPart) * 1000;
  759. Result := x.LowPart;
  760. {$ELSE}
  761. Result := Trunc((tick / freq) * 1000) and High(LongWord)
  762. {$ENDIF}
  763. end
  764. else
  765. Result := Windows.GetTickCount;
  766. end;
  767. {$ENDIF}
  768. {==============================================================================}
  769. function TickDelta(TickOld, TickNew: LongWord): LongWord;
  770. begin
  771. //if DWord is signed type (older Deplhi),
  772. // then it not work properly on differencies larger then maxint!
  773. Result := 0;
  774. if TickOld <> TickNew then
  775. begin
  776. if TickNew < TickOld then
  777. begin
  778. TickNew := TickNew + LongWord(MaxInt) + 1;
  779. TickOld := TickOld + LongWord(MaxInt) + 1;
  780. end;
  781. Result := TickNew - TickOld;
  782. if TickNew < TickOld then
  783. if Result > 0 then
  784. Result := 0 - Result;
  785. end;
  786. end;
  787. {==============================================================================}
  788. function CodeInt(Value: Word): Ansistring;
  789. begin
  790. setlength(result, 2);
  791. result[1] := AnsiChar(Value div 256);
  792. result[2] := AnsiChar(Value mod 256);
  793. // Result := AnsiChar(Value div 256) + AnsiChar(Value mod 256)
  794. end;
  795. {==============================================================================}
  796. function DecodeInt(const Value: Ansistring; Index: Integer): Word;
  797. var
  798. x, y: Byte;
  799. begin
  800. if Length(Value) > Index then
  801. x := Ord(Value[Index])
  802. else
  803. x := 0;
  804. if Length(Value) >= (Index + 1) then
  805. y := Ord(Value[Index + 1])
  806. else
  807. y := 0;
  808. Result := x * 256 + y;
  809. end;
  810. {==============================================================================}
  811. function CodeLongInt(Value: Longint): Ansistring;
  812. var
  813. x, y: word;
  814. begin
  815. // this is fix for negative numbers on systems where longint = integer
  816. x := (Value shr 16) and integer($ffff);
  817. y := Value and integer($ffff);
  818. setlength(result, 4);
  819. result[1] := AnsiChar(x div 256);
  820. result[2] := AnsiChar(x mod 256);
  821. result[3] := AnsiChar(y div 256);
  822. result[4] := AnsiChar(y mod 256);
  823. end;
  824. {==============================================================================}
  825. function DecodeLongInt(const Value: Ansistring; Index: Integer): LongInt;
  826. var
  827. x, y: Byte;
  828. xl, yl: Byte;
  829. begin
  830. if Length(Value) > Index then
  831. x := Ord(Value[Index])
  832. else
  833. x := 0;
  834. if Length(Value) >= (Index + 1) then
  835. y := Ord(Value[Index + 1])
  836. else
  837. y := 0;
  838. if Length(Value) >= (Index + 2) then
  839. xl := Ord(Value[Index + 2])
  840. else
  841. xl := 0;
  842. if Length(Value) >= (Index + 3) then
  843. yl := Ord(Value[Index + 3])
  844. else
  845. yl := 0;
  846. Result := ((x * 256 + y) * 65536) + (xl * 256 + yl);
  847. end;
  848. {==============================================================================}
  849. function DumpStr(const Buffer: Ansistring): string;
  850. var
  851. n: Integer;
  852. begin
  853. Result := '';
  854. for n := 1 to Length(Buffer) do
  855. Result := Result + ' +#$' + IntToHex(Ord(Buffer[n]), 2);
  856. end;
  857. {==============================================================================}
  858. function DumpExStr(const Buffer: Ansistring): string;
  859. var
  860. n: Integer;
  861. x: Byte;
  862. begin
  863. Result := '';
  864. for n := 1 to Length(Buffer) do
  865. begin
  866. x := Ord(Buffer[n]);
  867. if x in [65..90, 97..122] then
  868. Result := Result + ' +''' + char(x) + ''''
  869. else
  870. Result := Result + ' +#$' + IntToHex(Ord(Buffer[n]), 2);
  871. end;
  872. end;
  873. {==============================================================================}
  874. procedure Dump(const Buffer: AnsiString; DumpFile: string);
  875. var
  876. f: Text;
  877. begin
  878. AssignFile(f, DumpFile);
  879. if FileExists(DumpFile) then
  880. DeleteFile(DumpFile);
  881. Rewrite(f);
  882. try
  883. Writeln(f, DumpStr(Buffer));
  884. finally
  885. CloseFile(f);
  886. end;
  887. end;
  888. {==============================================================================}
  889. procedure DumpEx(const Buffer: AnsiString; DumpFile: string);
  890. var
  891. f: Text;
  892. begin
  893. AssignFile(f, DumpFile);
  894. if FileExists(DumpFile) then
  895. DeleteFile(DumpFile);
  896. Rewrite(f);
  897. try
  898. Writeln(f, DumpExStr(Buffer));
  899. finally
  900. CloseFile(f);
  901. end;
  902. end;
  903. {==============================================================================}
  904. function TrimSPLeft(const S: string): string;
  905. var
  906. I, L: Integer;
  907. begin
  908. Result := '';
  909. if S = '' then
  910. Exit;
  911. L := Length(S);
  912. I := 1;
  913. while (I <= L) and (S[I] = ' ') do
  914. Inc(I);
  915. Result := Copy(S, I, Maxint);
  916. end;
  917. {==============================================================================}
  918. function TrimSPRight(const S: string): string;
  919. var
  920. I: Integer;
  921. begin
  922. Result := '';
  923. if S = '' then
  924. Exit;
  925. I := Length(S);
  926. while (I > 0) and (S[I] = ' ') do
  927. Dec(I);
  928. Result := Copy(S, 1, I);
  929. end;
  930. {==============================================================================}
  931. function TrimSP(const S: string): string;
  932. begin
  933. Result := TrimSPLeft(s);
  934. Result := TrimSPRight(Result);
  935. end;
  936. {==============================================================================}
  937. function SeparateLeft(const Value, Delimiter: string): string;
  938. var
  939. x: Integer;
  940. begin
  941. x := Pos(Delimiter, Value);
  942. if x < 1 then
  943. Result := Value
  944. else
  945. Result := Copy(Value, 1, x - 1);
  946. end;
  947. {==============================================================================}
  948. function SeparateRight(const Value, Delimiter: string): string;
  949. var
  950. x: Integer;
  951. begin
  952. x := Pos(Delimiter, Value);
  953. if x > 0 then
  954. x := x + Length(Delimiter) - 1;
  955. Result := Copy(Value, x + 1, Length(Value) - x);
  956. end;
  957. {==============================================================================}
  958. function GetParameter(const Value, Parameter: string): string;
  959. var
  960. s: string;
  961. v: string;
  962. begin
  963. Result := '';
  964. v := Value;
  965. while v <> '' do
  966. begin
  967. s := Trim(FetchEx(v, ';', '"'));
  968. if Pos(Uppercase(parameter), Uppercase(s)) = 1 then
  969. begin
  970. Delete(s, 1, Length(Parameter));
  971. s := Trim(s);
  972. if s = '' then
  973. Break;
  974. if s[1] = '=' then
  975. begin
  976. Result := Trim(SeparateRight(s, '='));
  977. Result := UnquoteStr(Result, '"');
  978. break;
  979. end;
  980. end;
  981. end;
  982. end;
  983. {==============================================================================}
  984. procedure ParseParametersEx(Value, Delimiter: string; const Parameters: TStrings);
  985. var
  986. s: string;
  987. begin
  988. Parameters.Clear;
  989. while Value <> '' do
  990. begin
  991. s := Trim(FetchEx(Value, Delimiter, '"'));
  992. Parameters.Add(s);
  993. end;
  994. end;
  995. {==============================================================================}
  996. procedure ParseParameters(Value: string; const Parameters: TStrings);
  997. begin
  998. ParseParametersEx(Value, ';', Parameters);
  999. end;
  1000. {==============================================================================}
  1001. function IndexByBegin(Value: string; const List: TStrings): integer;
  1002. var
  1003. n: integer;
  1004. s: string;
  1005. begin
  1006. Result := -1;
  1007. Value := uppercase(Value);
  1008. for n := 0 to List.Count -1 do
  1009. begin
  1010. s := UpperCase(List[n]);
  1011. if Pos(Value, s) = 1 then
  1012. begin
  1013. Result := n;
  1014. Break;
  1015. end;
  1016. end;
  1017. end;
  1018. {==============================================================================}
  1019. function GetEmailAddr(const Value: string): string;
  1020. var
  1021. s: string;
  1022. begin
  1023. s := SeparateRight(Value, '<');
  1024. s := SeparateLeft(s, '>');
  1025. Result := Trim(s);
  1026. end;
  1027. {==============================================================================}
  1028. function GetEmailDesc(Value: string): string;
  1029. var
  1030. s: string;
  1031. begin
  1032. Value := Trim(Value);
  1033. s := SeparateRight(Value, '"');
  1034. if s <> Value then
  1035. s := SeparateLeft(s, '"')
  1036. else
  1037. begin
  1038. s := SeparateLeft(Value, '<');
  1039. if s = Value then
  1040. begin
  1041. s := SeparateRight(Value, '(');
  1042. if s <> Value then
  1043. s := SeparateLeft(s, ')')
  1044. else
  1045. s := '';
  1046. end;
  1047. end;
  1048. Result := Trim(s);
  1049. end;
  1050. {==============================================================================}
  1051. function StrToHex(const Value: Ansistring): string;
  1052. var
  1053. n: Integer;
  1054. begin
  1055. Result := '';
  1056. for n := 1 to Length(Value) do
  1057. Result := Result + IntToHex(Byte(Value[n]), 2);
  1058. Result := LowerCase(Result);
  1059. end;
  1060. {==============================================================================}
  1061. function IntToBin(Value: Integer; Digits: Byte): string;
  1062. var
  1063. x, y, n: Integer;
  1064. begin
  1065. Result := '';
  1066. x := Value;
  1067. repeat
  1068. y := x mod 2;
  1069. x := x div 2;
  1070. if y > 0 then
  1071. Result := '1' + Result
  1072. else
  1073. Result := '0' + Result;
  1074. until x = 0;
  1075. x := Length(Result);
  1076. for n := x to Digits - 1 do
  1077. Result := '0' + Result;
  1078. end;
  1079. {==============================================================================}
  1080. function BinToInt(const Value: string): Integer;
  1081. var
  1082. n: Integer;
  1083. begin
  1084. Result := 0;
  1085. for n := 1 to Length(Value) do
  1086. begin
  1087. if Value[n] = '0' then
  1088. Result := Result * 2
  1089. else
  1090. if Value[n] = '1' then
  1091. Result := Result * 2 + 1
  1092. else
  1093. Break;
  1094. end;
  1095. end;
  1096. {==============================================================================}
  1097. function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path,
  1098. Para: string): string;
  1099. var
  1100. x, y: Integer;
  1101. sURL: string;
  1102. s: string;
  1103. s1, s2: string;
  1104. begin
  1105. Prot := 'http';
  1106. User := '';
  1107. Pass := '';
  1108. Port := '80';
  1109. Para := '';
  1110. x := Pos('://', URL);
  1111. if x > 0 then
  1112. begin
  1113. Prot := SeparateLeft(URL, '://');
  1114. sURL := SeparateRight(URL, '://');
  1115. end
  1116. else
  1117. sURL := URL;
  1118. if UpperCase(Prot) = 'HTTPS' then
  1119. Port := '443';
  1120. if UpperCase(Prot) = 'FTP' then
  1121. Port := '21';
  1122. x := Pos('@', sURL);
  1123. y := Pos('/', sURL);
  1124. if (x > 0) and ((x < y) or (y < 1))then
  1125. begin
  1126. s := SeparateLeft(sURL, '@');
  1127. sURL := SeparateRight(sURL, '@');
  1128. x := Pos(':', s);
  1129. if x > 0 then
  1130. begin
  1131. User := SeparateLeft(s, ':');
  1132. Pass := SeparateRight(s, ':');
  1133. end
  1134. else
  1135. User := s;
  1136. end;
  1137. x := Pos('/', sURL);
  1138. if x > 0 then
  1139. begin
  1140. s1 := SeparateLeft(sURL, '/');
  1141. s2 := SeparateRight(sURL, '/');
  1142. end
  1143. else
  1144. begin
  1145. s1 := sURL;
  1146. s2 := '';
  1147. end;
  1148. if Pos('[', s1) = 1 then
  1149. begin
  1150. Host := Separateleft(s1, ']');
  1151. Delete(Host, 1, 1);
  1152. s1 := SeparateRight(s1, ']');
  1153. if Pos(':', s1) = 1 then
  1154. Port := SeparateRight(s1, ':');
  1155. end
  1156. else
  1157. begin
  1158. x := Pos(':', s1);
  1159. if x > 0 then
  1160. begin
  1161. Host := SeparateLeft(s1, ':');
  1162. Port := SeparateRight(s1, ':');
  1163. end
  1164. else
  1165. Host := s1;
  1166. end;
  1167. Result := '/' + s2;
  1168. x := Pos('?', s2);
  1169. if x > 0 then
  1170. begin
  1171. Path := '/' + SeparateLeft(s2, '?');
  1172. Para := SeparateRight(s2, '?');
  1173. end
  1174. else
  1175. Path := '/' + s2;
  1176. if Host = '' then
  1177. Host := 'localhost';
  1178. end;
  1179. {==============================================================================}
  1180. function ReplaceString(Value, Search, Replace: AnsiString): AnsiString;
  1181. var
  1182. x, l, ls, lr: Integer;
  1183. begin
  1184. if (Value = '') or (Search = '') then
  1185. begin
  1186. Result := Value;
  1187. Exit;
  1188. end;
  1189. ls := Length(Search);
  1190. lr := Length(Replace);
  1191. Result := '';
  1192. x := Pos(Search, Value);
  1193. while x > 0 do
  1194. begin
  1195. {$IFNDEF CIL}
  1196. l := Length(Result);
  1197. SetLength(Result, l + x - 1);
  1198. Move(Pointer(Value)^, Pointer(@Result[l + 1])^, x - 1);
  1199. {$ELSE}
  1200. Result:=Result+Copy(Value,1,x-1);
  1201. {$ENDIF}
  1202. {$IFNDEF CIL}
  1203. l := Length(Result);
  1204. SetLength(Result, l + lr);
  1205. Move(Pointer(Replace)^, Pointer(@Result[l + 1])^, lr);
  1206. {$ELSE}
  1207. Result:=Result+Replace;
  1208. {$ENDIF}
  1209. Delete(Value, 1, x - 1 + ls);
  1210. x := Pos(Search, Value);
  1211. end;
  1212. Result := Result + Value;
  1213. end;
  1214. {==============================================================================}
  1215. function RPosEx(const Sub, Value: string; From: integer): Integer;
  1216. var
  1217. n: Integer;
  1218. l: Integer;
  1219. begin
  1220. result := 0;
  1221. l := Length(Sub);
  1222. for n := From - l + 1 downto 1 do
  1223. begin
  1224. if Copy(Value, n, l) = Sub then
  1225. begin
  1226. result := n;
  1227. break;
  1228. end;
  1229. end;
  1230. end;
  1231. {==============================================================================}
  1232. function RPos(const Sub, Value: String): Integer;
  1233. begin
  1234. Result := RPosEx(Sub, Value, Length(Value));
  1235. end;
  1236. {==============================================================================}
  1237. function FetchBin(var Value: string; const Delimiter: string): string;
  1238. var
  1239. s: string;
  1240. begin
  1241. Result := SeparateLeft(Value, Delimiter);
  1242. s := SeparateRight(Value, Delimiter);
  1243. if s = Value then
  1244. Value := ''
  1245. else
  1246. Value := s;
  1247. end;
  1248. {==============================================================================}
  1249. function Fetch(var Value: string; const Delimiter: string): string;
  1250. begin
  1251. Result := FetchBin(Value, Delimiter);
  1252. Result := TrimSP(Result);
  1253. Value := TrimSP(Value);
  1254. end;
  1255. {==============================================================================}
  1256. function FetchEx(var Value: string; const Delimiter, Quotation: string): string;
  1257. var
  1258. b: Boolean;
  1259. begin
  1260. Result := '';
  1261. b := False;
  1262. while Length(Value) > 0 do
  1263. begin
  1264. if b then
  1265. begin
  1266. if Pos(Quotation, Value) = 1 then
  1267. b := False;
  1268. Result := Result + Value[1];
  1269. Delete(Value, 1, 1);
  1270. end
  1271. else
  1272. begin
  1273. if Pos(Delimiter, Value) = 1 then
  1274. begin
  1275. Delete(Value, 1, Length(delimiter));
  1276. break;
  1277. end;
  1278. b := Pos(Quotation, Value) = 1;
  1279. Result := Result + Value[1];
  1280. Delete(Value, 1, 1);
  1281. end;
  1282. end;
  1283. end;
  1284. {==============================================================================}
  1285. function IsBinaryString(const Value: AnsiString): Boolean;
  1286. var
  1287. n: integer;
  1288. begin
  1289. Result := False;
  1290. for n := 1 to Length(Value) do
  1291. if Value[n] in [#0..#8, #10..#31] then
  1292. //ignore null-terminated strings
  1293. if not ((n = Length(value)) and (Value[n] = AnsiChar(#0))) then
  1294. begin
  1295. Result := True;
  1296. Break;
  1297. end;
  1298. end;
  1299. {==============================================================================}
  1300. function PosCRLF(const Value: AnsiString; var Terminator: AnsiString): integer;
  1301. var
  1302. n, l: integer;
  1303. begin
  1304. Result := -1;
  1305. Terminator := '';
  1306. l := length(value);
  1307. for n := 1 to l do
  1308. if value[n] in [#$0d, #$0a] then
  1309. begin
  1310. Result := n;
  1311. Terminator := Value[n];
  1312. if n <> l then
  1313. case value[n] of
  1314. #$0d:
  1315. if value[n + 1] = #$0a then
  1316. Terminator := #$0d + #$0a;
  1317. #$0a:
  1318. if value[n + 1] = #$0d then
  1319. Terminator := #$0a + #$0d;
  1320. end;
  1321. Break;
  1322. end;
  1323. end;
  1324. {==============================================================================}
  1325. Procedure StringsTrim(const Value: TStrings);
  1326. var
  1327. n: integer;
  1328. begin
  1329. for n := Value.Count - 1 downto 0 do
  1330. if Value[n] = '' then
  1331. Value.Delete(n)
  1332. else
  1333. Break;
  1334. end;
  1335. {==============================================================================}
  1336. function PosFrom(const SubStr, Value: String; From: integer): integer;
  1337. var
  1338. ls,lv: integer;
  1339. begin
  1340. Result := 0;
  1341. ls := Length(SubStr);
  1342. lv := Length(Value);
  1343. if (ls = 0) or (lv = 0) then
  1344. Exit;
  1345. if From < 1 then
  1346. From := 1;
  1347. while (ls + from - 1) <= (lv) do
  1348. begin
  1349. {$IFNDEF CIL}
  1350. if CompareMem(@SubStr[1],@Value[from],ls) then
  1351. {$ELSE}
  1352. if SubStr = copy(Value, from, ls) then
  1353. {$ENDIF}
  1354. begin
  1355. result := from;
  1356. break;
  1357. end
  1358. else
  1359. inc(from);
  1360. end;
  1361. end;
  1362. {==============================================================================}
  1363. {$IFNDEF CIL}
  1364. function IncPoint(const p: pointer; Value: integer): pointer;
  1365. begin
  1366. Result := PAnsiChar(p) + Value;
  1367. end;
  1368. {$ENDIF}
  1369. {==============================================================================}
  1370. //improved by 'DoggyDawg'
  1371. function GetBetween(const PairBegin, PairEnd, Value: string): string;
  1372. var
  1373. n: integer;
  1374. x: integer;
  1375. s: string;
  1376. lenBegin: integer;
  1377. lenEnd: integer;
  1378. str: string;
  1379. max: integer;
  1380. begin
  1381. lenBegin := Length(PairBegin);
  1382. lenEnd := Length(PairEnd);
  1383. n := Length(Value);
  1384. if (Value = PairBegin + PairEnd) then
  1385. begin
  1386. Result := '';//nothing between
  1387. exit;
  1388. end;
  1389. if (n < lenBegin + lenEnd) then
  1390. begin
  1391. Result := Value;
  1392. exit;
  1393. end;
  1394. s := SeparateRight(Value, PairBegin);
  1395. if (s = Value) then
  1396. begin
  1397. Result := Value;
  1398. exit;
  1399. end;
  1400. n := Pos(PairEnd, s);
  1401. if (n = 0) then
  1402. begin
  1403. Result := Value;
  1404. exit;
  1405. end;
  1406. Result := '';
  1407. x := 1;
  1408. max := Length(s) - lenEnd + 1;
  1409. for n := 1 to max do
  1410. begin
  1411. str := copy(s, n, lenEnd);
  1412. if (str = PairEnd) then
  1413. begin
  1414. Dec(x);
  1415. if (x <= 0) then
  1416. Break;
  1417. end;
  1418. str := copy(s, n, lenBegin);
  1419. if (str = PairBegin) then
  1420. Inc(x);
  1421. Result := Result + s[n];
  1422. end;
  1423. end;
  1424. {==============================================================================}
  1425. function CountOfChar(const Value: string; Chr: char): integer;
  1426. var
  1427. n: integer;
  1428. begin
  1429. Result := 0;
  1430. for n := 1 to Length(Value) do
  1431. if Value[n] = chr then
  1432. Inc(Result);
  1433. end;
  1434. {==============================================================================}
  1435. // ! do not use AnsiExtractQuotedStr, it's very buggy and can crash application!
  1436. function UnquoteStr(const Value: string; Quote: Char): string;
  1437. var
  1438. n: integer;
  1439. inq, dq: Boolean;
  1440. c, cn: char;
  1441. begin
  1442. Result := '';
  1443. if Value = '' then
  1444. Exit;
  1445. if Value = Quote + Quote then
  1446. Exit;
  1447. inq := False;
  1448. dq := False;
  1449. for n := 1 to Length(Value) do
  1450. begin
  1451. c := Value[n];
  1452. if n <> Length(Value) then
  1453. cn := Value[n + 1]
  1454. else
  1455. cn := #0;
  1456. if c = quote then
  1457. if dq then
  1458. dq := False
  1459. else
  1460. if not inq then
  1461. inq := True
  1462. else
  1463. if cn = quote then
  1464. begin
  1465. Result := Result + Quote;
  1466. dq := True;
  1467. end
  1468. else
  1469. inq := False
  1470. else
  1471. Result := Result + c;
  1472. end;
  1473. end;
  1474. {==============================================================================}
  1475. function QuoteStr(const Value: string; Quote: Char): string;
  1476. var
  1477. n: integer;
  1478. begin
  1479. Result := '';
  1480. for n := 1 to length(value) do
  1481. begin
  1482. Result := result + Value[n];
  1483. if value[n] = Quote then
  1484. Result := Result + Quote;
  1485. end;
  1486. Result := Quote + Result + Quote;
  1487. end;
  1488. {==============================================================================}
  1489. procedure HeadersToList(const Value: TStrings);
  1490. var
  1491. n, x, y: integer;
  1492. s: string;
  1493. begin
  1494. for n := 0 to Value.Count -1 do
  1495. begin
  1496. s := Value[n];
  1497. x := Pos(':', s);
  1498. if x > 0 then
  1499. begin
  1500. y:= Pos('=',s);
  1501. if not ((y > 0) and (y < x)) then
  1502. begin
  1503. s[x] := '=';
  1504. Value[n] := s;
  1505. end;
  1506. end;
  1507. end;
  1508. end;
  1509. {==============================================================================}
  1510. procedure ListToHeaders(const Value: TStrings);
  1511. var
  1512. n, x: integer;
  1513. s: string;
  1514. begin
  1515. for n := 0 to Value.Count -1 do
  1516. begin
  1517. s := Value[n];
  1518. x := Pos('=', s);
  1519. if x > 0 then
  1520. begin
  1521. s[x] := ':';
  1522. Value[n] := s;
  1523. end;
  1524. end;
  1525. end;
  1526. {==============================================================================}
  1527. function SwapBytes(Value: integer): integer;
  1528. var
  1529. s: AnsiString;
  1530. x, y, xl, yl: Byte;
  1531. begin
  1532. s := CodeLongInt(Value);
  1533. x := Ord(s[4]);
  1534. y := Ord(s[3]);
  1535. xl := Ord(s[2]);
  1536. yl := Ord(s[1]);
  1537. Result := ((x * 256 + y) * 65536) + (xl * 256 + yl);
  1538. end;
  1539. {==============================================================================}
  1540. function ReadStrFromStream(const Stream: TStream; len: integer): AnsiString;
  1541. var
  1542. x: integer;
  1543. {$IFDEF CIL}
  1544. buf: Array of Byte;
  1545. {$ENDIF}
  1546. begin
  1547. {$IFDEF CIL}
  1548. Setlength(buf, Len);
  1549. x := Stream.read(buf, Len);
  1550. SetLength(buf, x);
  1551. Result := StringOf(Buf);
  1552. {$ELSE}
  1553. Setlength(Result, Len);
  1554. x := Stream.read(PAnsiChar(Result)^, Len);
  1555. SetLength(Result, x);
  1556. {$ENDIF}
  1557. end;
  1558. {==============================================================================}
  1559. procedure WriteStrToStream(const Stream: TStream; Value: AnsiString);
  1560. {$IFDEF CIL}
  1561. var
  1562. buf: Array of Byte;
  1563. {$ENDIF}
  1564. begin
  1565. {$IFDEF CIL}
  1566. buf := BytesOf(Value);
  1567. Stream.Write(buf,length(Value));
  1568. {$ELSE}
  1569. Stream.Write(PAnsiChar(Value)^, Length(Value));
  1570. {$ENDIF}
  1571. end;
  1572. {==============================================================================}
  1573. function GetTempFile(const Dir, prefix: AnsiString): AnsiString;
  1574. {$IFNDEF FPC}
  1575. {$IFDEF MSWINDOWS}
  1576. var
  1577. Path: AnsiString;
  1578. x: integer;
  1579. {$ENDIF}
  1580. {$ENDIF}
  1581. begin
  1582. {$IFDEF FPC}
  1583. Result := GetTempFileName(Dir, Prefix);
  1584. {$ELSE}
  1585. {$IFNDEF MSWINDOWS}
  1586. Result := tempnam(Pointer(Dir), Pointer(prefix));
  1587. {$ELSE}
  1588. {$IFDEF CIL}
  1589. Result := System.IO.Path.GetTempFileName;
  1590. {$ELSE}
  1591. if Dir = '' then
  1592. begin
  1593. SetLength(Path, MAX_PATH);
  1594. x := GetTempPath(Length(Path), PChar(Path));
  1595. SetLength(Path, x);
  1596. end
  1597. else
  1598. Path := Dir;
  1599. x := Length(Path);
  1600. if Path[x] <> '\' then
  1601. Path := Path + '\';
  1602. SetLength(Result, MAX_PATH + 1);
  1603. GetTempFileName(PChar(Path), PChar(Prefix), 0, PChar(Result));
  1604. Result := PChar(Result);
  1605. SetFileattributes(PChar(Result), GetFileAttributes(PChar(Result)) or FILE_ATTRIBUTE_TEMPORARY);
  1606. {$ENDIF}
  1607. {$ENDIF}
  1608. {$ENDIF}
  1609. end;
  1610. {==============================================================================}
  1611. function PadString(const Value: AnsiString; len: integer; Pad: AnsiChar): AnsiString;
  1612. begin
  1613. if length(value) >= len then
  1614. Result := Copy(value, 1, len)
  1615. else
  1616. Result := Value + StringOfChar(Pad, len - length(value));
  1617. end;
  1618. {==============================================================================}
  1619. function XorString(Indata1, Indata2: AnsiString): AnsiString;
  1620. var
  1621. i: integer;
  1622. begin
  1623. Indata2 := PadString(Indata2, length(Indata1), #0);
  1624. Result := '';
  1625. for i := 1 to length(Indata1) do
  1626. Result := Result + AnsiChar(ord(Indata1[i]) xor ord(Indata2[i]));
  1627. end;
  1628. {==============================================================================}
  1629. function NormalizeHeader(Value: TStrings; var Index: Integer): string;
  1630. var
  1631. s, t: string;
  1632. n: Integer;
  1633. begin
  1634. s := Value[Index];
  1635. Inc(Index);
  1636. if s <> '' then
  1637. while (Value.Count - 1) > Index do
  1638. begin
  1639. t := Value[Index];
  1640. if t = '' then
  1641. Break;
  1642. for n := 1 to Length(t) do
  1643. if t[n] = #9 then
  1644. t[n] := ' ';
  1645. if not(AnsiChar(t[1]) in [' ', '"', ':', '=']) then
  1646. Break
  1647. else
  1648. begin
  1649. s := s + ' ' + Trim(t);
  1650. Inc(Index);
  1651. end;
  1652. end;
  1653. Result := TrimRight(s);
  1654. end;
  1655. {==============================================================================}
  1656. {pf}
  1657. procedure SearchForLineBreak(var APtr:PANSIChar; AEtx:PANSIChar; out ABol:PANSIChar; out ALength:integer);
  1658. begin
  1659. ABol := APtr;
  1660. while (APtr<AEtx) and not (APtr^ in [#0,#10,#13]) do
  1661. inc(APtr);
  1662. ALength := APtr-ABol;
  1663. end;
  1664. {/pf}
  1665. {pf}
  1666. procedure SkipLineBreak(var APtr:PANSIChar; AEtx:PANSIChar);
  1667. begin
  1668. if (APtr<AEtx) and (APtr^=#13) then
  1669. inc(APtr);
  1670. if (APtr<AEtx) and (APtr^=#10) then
  1671. inc(APtr);
  1672. end;
  1673. {/pf}
  1674. {pf}
  1675. procedure SkipNullLines(var APtr:PANSIChar; AEtx:PANSIChar);
  1676. var
  1677. bol: PANSIChar;
  1678. lng: integer;
  1679. begin
  1680. while (APtr<AEtx) do
  1681. begin
  1682. SearchForLineBreak(APtr,AEtx,bol,lng);
  1683. SkipLineBreak(APtr,AEtx);
  1684. if lng>0 then
  1685. begin
  1686. APtr := bol;
  1687. Break;
  1688. end;
  1689. end;
  1690. end;
  1691. {/pf}
  1692. {pf}
  1693. procedure CopyLinesFromStreamUntilNullLine(var APtr:PANSIChar; AEtx:PANSIChar; ALines:TStrings);
  1694. var
  1695. bol: PANSIChar;
  1696. lng: integer;
  1697. s: ANSIString;
  1698. begin
  1699. // Copying until body separator will be reached
  1700. while (APtr<AEtx) and (APtr^<>#0) do
  1701. begin
  1702. SearchForLineBreak(APtr,AEtx,bol,lng);
  1703. SkipLineBreak(APtr,AEtx);
  1704. if lng=0 then
  1705. Break;
  1706. SetString(s,bol,lng);
  1707. ALines.Add(s);
  1708. end;
  1709. end;
  1710. {/pf}
  1711. {pf}
  1712. procedure CopyLinesFromStreamUntilBoundary(var APtr:PANSIChar; AEtx:PANSIChar; ALines:TStrings; const ABoundary:ANSIString);
  1713. var
  1714. bol: PANSIChar;
  1715. lng: integer;
  1716. s: ANSIString;
  1717. BackStop: ANSIString;
  1718. eob1: PANSIChar;
  1719. eob2: PANSIChar;
  1720. begin
  1721. BackStop := '--'+ABoundary;
  1722. eob2 := nil;
  1723. // Copying until Boundary will be reached
  1724. while (APtr<AEtx) do
  1725. begin
  1726. SearchForLineBreak(APtr,AEtx,bol,lng);
  1727. SkipLineBreak(APtr,AEtx);
  1728. eob1 := MatchBoundary(bol,APtr,ABoundary);
  1729. if Assigned(eob1) then
  1730. eob2 := MatchLastBoundary(bol,AEtx,ABoundary);
  1731. if Assigned(eob2) then
  1732. begin
  1733. APtr := eob2;
  1734. Break;
  1735. end
  1736. else if Assigned(eob1) then
  1737. begin
  1738. APtr := eob1;
  1739. Break;
  1740. end
  1741. else
  1742. begin
  1743. SetString(s,bol,lng);
  1744. ALines.Add(s);
  1745. end;
  1746. end;
  1747. end;
  1748. {/pf}
  1749. {pf}
  1750. function SearchForBoundary(var APtr:PANSIChar; AEtx:PANSIChar; const ABoundary:ANSIString): PANSIChar;
  1751. var
  1752. eob: PANSIChar;
  1753. Step: integer;
  1754. begin
  1755. Result := nil;
  1756. // Moving Aptr position forward until boundary will be reached
  1757. while (APtr<AEtx) do
  1758. begin
  1759. if strlcomp(APtr,#13#10'--',4)=0 then
  1760. begin
  1761. eob := MatchBoundary(APtr,AEtx,ABoundary);
  1762. Step := 4;
  1763. end
  1764. else if strlcomp(APtr,'--',2)=0 then
  1765. begin
  1766. eob := MatchBoundary(APtr,AEtx,ABoundary);
  1767. Step := 2;
  1768. end
  1769. else
  1770. begin
  1771. eob := nil;
  1772. Step := 1;
  1773. end;
  1774. if Assigned(eob) then
  1775. begin
  1776. Result := APtr; // boundary beginning
  1777. APtr := eob; // boundary end
  1778. exit;
  1779. end
  1780. else
  1781. inc(APtr,Step);
  1782. end;
  1783. end;
  1784. {/pf}
  1785. {pf}
  1786. function MatchBoundary(ABol,AEtx:PANSIChar; const ABoundary:ANSIString): PANSIChar;
  1787. var
  1788. MatchPos: PANSIChar;
  1789. Lng: integer;
  1790. begin
  1791. Result := nil;
  1792. MatchPos := ABol;
  1793. Lng := length(ABoundary);
  1794. if (MatchPos+2+Lng)>AETX then
  1795. exit;
  1796. if strlcomp(MatchPos,#13#10,2)=0 then
  1797. inc(MatchPos,2);
  1798. if (MatchPos+2+Lng)>AETX then
  1799. exit;
  1800. if strlcomp(MatchPos,'--',2)<>0 then
  1801. exit;
  1802. inc(MatchPos,2);
  1803. if strlcomp(MatchPos,PANSIChar(ABoundary),Lng)<>0 then
  1804. exit;
  1805. inc(MatchPos,Lng);
  1806. if ((MatchPos+2)<=AEtx) and (strlcomp(MatchPos,#13#10,2)=0) then
  1807. inc(MatchPos,2);
  1808. Result := MatchPos;
  1809. end;
  1810. {/pf}
  1811. {pf}
  1812. function MatchLastBoundary(ABOL,AETX:PANSIChar; const ABoundary:ANSIString): PANSIChar;
  1813. var
  1814. MatchPos: PANSIChar;
  1815. begin
  1816. Result := nil;
  1817. MatchPos := MatchBoundary(ABOL,AETX,ABoundary);
  1818. if not Assigned(MatchPos) then
  1819. exit;
  1820. if strlcomp(MatchPos,'--',2)<>0 then
  1821. exit;
  1822. inc(MatchPos,2);
  1823. if (MatchPos+2<=AEtx) and (strlcomp(MatchPos,#13#10,2)=0) then
  1824. inc(MatchPos,2);
  1825. Result := MatchPos;
  1826. end;
  1827. {/pf}
  1828. {pf}
  1829. function BuildStringFromBuffer(AStx,AEtx:PANSIChar): ANSIString;
  1830. var
  1831. lng: integer;
  1832. begin
  1833. Lng := 0;
  1834. if Assigned(AStx) and Assigned(AEtx) then
  1835. begin
  1836. Lng := AEtx-AStx;
  1837. if Lng<0 then
  1838. Lng := 0;
  1839. end;
  1840. SetString(Result,AStx,lng);
  1841. end;
  1842. {/pf}
  1843. {==============================================================================}
  1844. var
  1845. n: integer;
  1846. begin
  1847. for n := 1 to 12 do
  1848. begin
  1849. CustomMonthNames[n] := ShortMonthNames[n];
  1850. MyMonthNames[0, n] := ShortMonthNames[n];
  1851. end;
  1852. end.