1 { Version 050602. Copyright � Alexey A.Chernobaev, 1996-2005 }
2
3 { Some functions are based on a code from other freeware units:
4 1) StrUtils (RX Library) Copyright (c) 1995, 1996 AO ROSNO;
5 Copyright (c) 1997, 1998 Master-Bank;
6 2) QStrings Copyright (c) 2000, Andrew N. Driazgov; Portions (c) 2000,
7 Sergey G. Shcherbakov) }
8
9 unit VectStr;
10
11 interface
12
13 {$I VCheck.inc}
14
15 uses
16 {$IFDEF V_WIN}{$IFNDEF WIN32}Windows,{WinTypes, WinProcs,}{$ELSE}Windows,{$ENDIF}{$ENDIF} {by zcad}
17 SysUtils, ExtSys, ExtType{$IFNDEF UNIX},Windows{$ENDIF}
18 {$IFDEF V_WIDESTRINGS}{$IFDEF V_D4},SysConst{$ENDIF}{$ENDIF};
19
20 const
21 LoASCII = [#0..#31];
22 LoASCIIAndSpace = LoASCII + [' '];
23 Digits = ['0'..'9'];
24 OctalDigits = ['0'..'7'];
25 HexadecimalDigits = Digits + ['A'..'F', 'a'..'f'];
26 ASCIIUpperAlpha = ['A'..'Z'];
27 ASCIILowerAlpha = ['a'..'z'];
28 ASCIIAlpha = ASCIIUpperAlpha + ASCIILowerAlpha;
29 ASCIIAlphaNumeric = ASCIIAlpha + Digits;
30 ASCII_32to127 = [#32..#127];
31 Punctuation = ['!', ',', '.', ':', ';', '?'];
32 Brackets = ['(', ')', '[', ']', '{', '}'];
33
34 type
35 TCharSet = set of Char;
36
LoCasenull37 function LoCase(C: Char): Char; {$IFDEF V_INLINE}inline;{$ENDIF}
38 { ����������� ������ � ������ ������� ('A'..'Z' -> 'a'..'z') }
39 { converts a character to lowercase ('A'..'Z' -> 'a'..'z') }
40
NumOfCharsnull41 function NumOfChars(C: Char; const S: String): Integer;
42 {$IFDEF V_WIDESTRINGS}
NumOfWideCharsnull43 function NumOfWideChars(C: WideChar; const S: WideString): Integer;
44 {$ENDIF}
45 { ���������� ���������� ��������� ������� C � ������ S }
46 { returns the number of occurrences of the character C in the string S }
47
NumOfSubStrnull48 function NumOfSubStr(const SubS, S: String): Integer;
49 {$IFDEF V_WIDESTRINGS}
WideNumOfSubStrnull50 function WideNumOfSubStr(const SubS, S: WideString): Integer;
51 {$ENDIF}
52 { ���������� ���������� ��������� ��������� SubS � ������ S }
53 { returns the number of occurrences of the substring SubS in the string S }
54
55 {$IFDEF V_WIDESTRINGS}
WideCharInnull56 function WideCharIn(W: WideChar; const Chars: TCharSet): Boolean;
57 { Result:=(W < #256) and (Char(W) in Chars) }
58 {$ENDIF}
59
IsASCIIStringnull60 function IsASCIIString(const S: String): Boolean;
61 {$IFDEF V_WIDESTRINGS}
IsASCIIWideStringnull62 function IsASCIIWideString(const S: WideString): Boolean;
63 {$ENDIF}
64 { ���������� True ����� � ������ �����, ����� ������ S �� �������� ��������
65 � ������ >= 128 }
66 { returns True if and only if the string S doesn't contain characters with
67 codes >= 128 }
68
CharPosnull69 function CharPos(C: Char; const S: String;
70 From: Integer{$IFDEF V_DEFAULTS} = 1{$ENDIF}): Integer;
71 {$IFDEF V_WIDESTRINGS}
WideCharPosnull72 function WideCharPos(C: WideChar; const S: WideString;
73 From: Integer{$IFDEF V_DEFAULTS} = 1{$ENDIF}): Integer;
74 {$ENDIF}
75 { ���������� ������ ������� ��������� ������� � � ������ S, ������� � �������
76 From (>= 1); ���������� 0, ���� ������ �� ������ }
77 { returns the index of the first occurrence of the character C in the string S
78 starting from position From (>= 1); returns 0 if the character not found }
79
CharNPosnull80 function CharNPos(C: Char; const S: String; N: Integer;
81 From: Integer{$IFDEF V_DEFAULTS} = 1{$ENDIF}): Integer;
82 {$IFDEF V_WIDESTRINGS}
WideCharNPosnull83 function WideCharNPos(C: WideChar; const S: WideString; N: Integer;
84 From: Integer{$IFDEF V_DEFAULTS} = 1{$ENDIF}): Integer;
85 {$ENDIF}
86 { ���������� ������ N-�� (N >= 1) ��������� ������� � � ������ S, ������� �
87 ������� From (>= 1); ���������� 0, ���� ������ �� ������ }
88 { returns the index of the Nth (N >= 1) occurrence of the character C in the
89 string S starting from position From (>= 1); returns 0 if the character not
90 found }
91
LastPosnull92 function LastPos(C: Char; const S: String): Integer;
93 {$IFDEF V_WIDESTRINGS}
WideLastPosnull94 function WideLastPos(C: WideChar; const S: WideString): Integer;
95 {$ENDIF}
96 { ���� ������ C ������ � ������ S, �� ���������� ������ ���������� ���������
97 ����� �������, ����� ���������� 0 }
98 { if the string S contains the character C then returns the index of the last
99 occurrence of this character, otherwise returns 0 }
100
CharInSetPosnull101 function CharInSetPos(const Chars: TCharSet; const S: String;
102 From: Integer{$IFDEF V_DEFAULTS} = 1{$ENDIF}): Integer;
103 {$IFDEF V_WIDESTRINGS}
WideCharInSetPosnull104 function WideCharInSetPos(const Chars: TCharSet; const S: WideString;
105 From: Integer{$IFDEF V_DEFAULTS} = 1{$ENDIF}): Integer;
106 {$ENDIF}
107 { ���������� ������ ������� ��������� ������ �� ��������, �������� � Chars, �
108 ������ S, ������� � ������� From (>= 1); ���������� 0, ���� ������ �� ������ }
109 { returns the index of the first occurrence of any character from Chars in the
110 string S starting from position From (>= 1); returns 0 if the character
111 not found }
112
CharNotInSetPosnull113 function CharNotInSetPos(const Chars: TCharSet; const S: String;
114 From: Integer{$IFDEF V_DEFAULTS} = 1{$ENDIF}): Integer;
115 {$IFDEF V_WIDESTRINGS}
WideCharNotInSetPosnull116 function WideCharNotInSetPos(const Chars: TCharSet; const S: WideString;
117 From: Integer{$IFDEF V_DEFAULTS} = 1{$ENDIF}): Integer;
118 {$ENDIF}
119 { ���������� ������ ������� ��������� ������ �� ��������, �� �������� � Chars,
120 � ������ S, ������� � ������� From (>= 1); ���������� 0, ���� ����� ������
121 �� ��� ������ }
122 { returns the index of the first occurrence of any character NOT from Chars in
123 the string S starting from position From (>= 1); returns 0 if such character
124 was not found }
125
126 {$IFDEF V_WIN}
AnsiTextPosnull127 function AnsiTextPos(const SubS, S: String): Integer;
128 { ������ Pos, ���������������� � �������� �������� }
129 { case-insensitive analog of Pos }
130 {$ENDIF}
131
FirstUppernull132 function FirstUpper(const S: String): String;
133 procedure FirstUpperProc(var S: String);
134 { �������� ������ ������ S �� ��������� ����� }
135 { changes the first character of S to uppercase }
136
FirstLowernull137 function FirstLower(const S: String): String;
138 procedure FirstLowerProc(var S: String);
139 { �������� ������ ������ S �� �������� ����� }
140 { changes the first character of S to lowercase }
141
DelLastNnull142 function DelLastN(const S: String; N: Integer): String;
143 { ���������� ����� S ��� N ��������� �������� }
144 { returns a copy of S without the last N characters }
145
DelLastIfnull146 function DelLastIf(const S: String; C: Char): String;
147 { ���� ������ S ������������ �������� �, �� ��������� ����� ������ �� 1 �
148 ���������� ��, ����� ���������� ����� S }
149 { if the string S terminates with the character C then decreases the string
150 length by 1 and returns it, otherwise returns a copy of S }
151
FirstCharnull152 function FirstChar(const S: String): Char;
LastCharnull153 function LastChar(const S: String): Char;
154 {$IFDEF V_WIDESTRINGS}
WideFirstCharnull155 function WideFirstChar(const S: WideString): WideChar;
WideLastCharnull156 function WideLastChar(const S: WideString): WideChar;
157 {$ENDIF}
158 { see code }
159
EnsureLastnull160 function EnsureLast(const S: String; C: Char): String;
161 { ���� ������ S �� ������ � �� ������������ �������� �, �� ���������� (S + C),
162 ����� ���������� ����� S }
163 { if the string S is not empty and it doesn't end up with the character C then
164 returns (S + C), otherwise returns a copy of S }
165 {$IFDEF V_WIDESTRINGS}
WideEnsureLastnull166 function WideEnsureLast(const S: WideString; C: WideChar): WideString;
167 {$ENDIF}
168
CloseSentencenull169 function CloseSentence(const S: String): String;
170 procedure CloseSentenceProc(var S: String);
171 {$IFDEF V_WIDESTRINGS}
WideCloseSentencenull172 function WideCloseSentence(const S: WideString): WideString;
173 procedure WideCloseSentenceProc(var S: WideString);
174 {$ENDIF}
175
176 procedure ConcatDelimited(var S: String; const Tail: String; Delimiter: Char);
177 {$IFDEF V_WIDESTRINGS}
178 procedure WideConcatDelimited(var S: WideString; const Tail: WideString; Delimiter: WideChar);
179 {$ENDIF}
180
181 {$IFDEF V_WIDESTRINGS}
182 procedure WideAppend(var S: WideString; C: WideChar);
183 { S:=S + C }
184 procedure WideAppendStr(var S: WideString; const Tail: WideString);
185 { S:=S + Tail }
186 {$ENDIF}
187
PosFromnull188 function PosFrom(const SubStr, S: String; From: Integer): Integer;
189 { ������ System.Pos, �� SubStr ������, ������� � ������� From (>=1) }
190 { analog of System.Pos which searches for SubStr from the position From (>=1) }
191 {$IFDEF V_WIDESTRINGS}
WidePosFromnull192 function WidePosFrom(const SubStr, S: WideString; From: Integer): Integer;
193 {$ENDIF}
194
StartsWithnull195 function StartsWith(const S, What: String): Boolean;
196 { Result = (Copy(S, 1, Length(What)) = What) }
197 {$IFDEF V_WIDESTRINGS}
WideStartsWithnull198 function WideStartsWith(const S, What: WideString): Boolean;
199 {$ENDIF}
200
201 {$IFDEF V_WIN}
AnsiStartsWithnull202 function AnsiStartsWith(const S, What: String): Boolean;
203 { ������ StartsWith, ���������������� � �������� �������� }
204 { case-insensitive analog of StartsWith }
205 {$ENDIF}
206
EndsWithnull207 function EndsWith(const S, What: String): Boolean;
208 {$IFDEF V_WIDESTRINGS}
WideEndsWithnull209 function WideEndsWith(const S, What: WideString): Boolean;
210 {$ENDIF}
211
212 {$IFDEF V_DELPHI}
213 {$IFNDEF V_D3}
Trimnull214 function Trim(const S: String): String;
215 { ������� ������� � ������ <= ' ' � ������ � ����� ������ }
216 { removes leading and trailing characters with codes <= ' ' from the string }
217 {$ELSE}
TrimWnull218 function TrimW(const S: WideString): WideString;
219 {$ENDIF}
220 {$ENDIF}
221
222 {$IFNDEF V_D5} { Delphi 1-4, Free Pascal }
AnsiSameTextnull223 function AnsiSameText(const S1, S2: String): Boolean;
224 {$ENDIF}
225
226 {$IFDEF V_WIDESTRINGS}
227 {$IFNDEF V_D6}
WideCompareTextnull228 function WideCompareText(const S1, S2: WideString): Integer;
WideSameTextnull229 function WideSameText(const S1, S2: WideString): Boolean;
230 {$ENDIF}
231 {$ENDIF}
232
TrimTrailnull233 function TrimTrail(const S: String): String;
234 {$IFDEF V_WIDESTRINGS}
TrimTrailWnull235 function TrimTrailW(const S: WideString): WideString;
236 {$ENDIF}
237 { ������� ������� � ������ <= ' ' � ����� ������ }
238 { removes trailing characters with codes <= ' ' from the string }
239
TruncateAtZeronull240 function TruncateAtZero(const S: String): String;
241 procedure TruncateAtZeroProc(var S: String);
242 {$IFDEF V_WIDESTRINGS}
TruncateAtZeroWidenull243 function TruncateAtZeroWide(const S: WideString): WideString;
244 procedure TruncateAtZeroProcWide(var S: WideString);
245 {$ENDIF}
246 { �������� ������ �� ������ ��������� #0 }
247 { truncates the string at first #0 }
248
TrimLastNnull249 function TrimLastN(const S: String; N: Integer): String;
250 procedure TrimLastNProc(var S: String; N: Integer);
251 {$IFDEF V_WIDESTRINGS}
WideTrimLastNnull252 function WideTrimLastN(const S: WideString; N: Integer): WideString;
253 procedure WideTrimLastNProc(var S: WideString; N: Integer);
254 {$ENDIF}
255 { �������� ��������� N �������� ������ S (�.�. ��������� ����� S �� N) }
256 { truncates the last N characters from S (i.e. decreases the length of S by N) }
257
IsWhiteSpacenull258 function IsWhiteSpace(const S: String): Boolean;
259 { ���������� True, ���� ��� ������� S ������ ���� ����� #32 }
260 { returns True if all characters of S are lower or equal to #32 }
261
MakeStringnull262 function MakeString(C: Char; N: Integer): String;
263 {$IFDEF V_WIDESTRINGS}
MakeWideStringnull264 function MakeWideString(C: WideChar; N: Integer): WideString;
265 {$ENDIF}
266 { ������ MakeStr �� RX Library: ���������� ������, ��������� �� N �������� C }
267 { analog of MakeStr from RX Library: returns the string consisting of N
268 characters C }
269
AddCharnull270 function AddChar(C: Char; const S: String; N: Integer): String;
271 { �� RX Library: ���������� ����� S, ����������� �� ����� N ��������� C ����� }
272 { from RX Library: returns copy of S left-padded to length N with characters C }
273
ReplaceStrnull274 function ReplaceStr(const Value, FromStr, ToStr: String): String;
275 {$IFDEF V_WIDESTRINGS}
WideReplaceStrnull276 function WideReplaceStr(const Value, FromStr, ToStr: WideString): WideString;
277 {$ENDIF}
278 { �� RX Library: ���������� ������, ���������� �� Value ������� ���� ���������
279 FromStr �� ToStr }
280 { from RX Library: returns the result of replacing all occurrences of FromStr in
281 Value to ToStr }
282
283 procedure ReplaceCharProc(var S: String; FromChar, ToChar: Char);
ReplaceCharnull284 function ReplaceChar(const S: String; FromChar, ToChar: Char): String;
285 {$IFDEF V_WIDESTRINGS}
286 procedure WideReplaceCharProc(var S: WideString; FromChar, ToChar: WideChar);
WideReplaceCharnull287 function WideReplaceChar(const S: WideString; FromChar, ToChar: WideChar): WideString;
288 {$ENDIF}
289 { ���������� ������, ���������� �� Value ������� ���� �������� FromChar ��
290 ToChar }
291 { returns the result of replacing all occurrences of the FromChar character in
292 Value to ToChar }
293
ContainsCharsnull294 function ContainsChars(const S: String; Chars: TCharSet): Boolean;
ContainsCharsBufnull295 function ContainsCharsBuf(const Buf: PChar; Size: Integer;
296 const Chars: TCharSet): Boolean;
297 {$IFDEF V_WIDESTRINGS}
WideContainsCharsnull298 function WideContainsChars(const S: WideString; Chars: TCharSet): Boolean;
299 {$ENDIF}
300 { ���������, �������� �� S ���� �� ���� ������ �� ��������� Chars }
301 { checks whether S contains at least one character from Chars set }
302
ContainsOnlyCharsnull303 function ContainsOnlyChars(const S: String; const Chars: TCharSet): Boolean;
ContainsOnlyCharsBufnull304 function ContainsOnlyCharsBuf(const Buf: PChar; Size: Integer;
305 const Chars: TCharSet): Boolean;
306 { ���������� True, ���� ������ �������� ������ ������� �� Chars }
307 { returns True if the given string contains only characters from Chars }
308
DelDupCharnull309 function DelDupChar(const S: String; C: Char): String;
310 { ���������� ������, ���������� �� S ��������� ������������� �������� C (�������
311 �������, �� ������ ������ ������ ������ �������� C �������� ���� ������) }
312 { returns the result of deleting duplicate characters C in the string S (in other
313 words, only one character remains from every group of adjacent characters C) }
314
315 {$IFDEF V_LONGSTRINGS}
DecodeCEscapesnull316 function DecodeCEscapes(const S: String): String;
317 { ���������� ������, ���������� �� S ������� ���� escape-�������������������
318 �� ��������������� ������������������ ASCII-��������, ��� ��� ������ �������
319 ��������� printf ����������� ���������� ������� ���������� ����� C (��������,
320 "\n" ���������� �� #13#10, "\t" - �� #9 � �.�.) }
321 { returns the result of replacing all escape-sequences in the string S to the
322 corresponding sequences of ASCII codes as the printf-family functions of the
323 standard C-language run-time library do (e.g. "\n" will be replaced to #13#10,
324 "\t" - to #9, etc.) }
325
EncodeCEscapesnull326 function EncodeCEscapes(const S: String; Only7Bit: Boolean): String;
327 { �������, �������� � DecodeCEscapes; ��� ������� � ������ [#0..#31] �����
328 ������������ escape-�������������������� \xNN, ��� NN - ����������������� ���
329 ������� (���� Only7Bit = True, �� ������� � ������ >= #128 ����� �����
330 ������������) }
331 { inverse function for DecodeCEscapes; all characters with codes [#0..#31] will
332 be encoded with escape-sequences \xNN, where NN is the hexadecimal character
333 code (if Only7Bit = True then characters with codes >= #128 will be encoded
334 also) }
335 {$ENDIF}
336
337 {$IFDEF WIN32}
WordPosnull338 function WordPos(SubWord, S: String; CaseSensitive: Boolean): Integer;
339 { ���� SubWord ������ � ������ S ��� ����� �����, �� ���������� ������ �������
340 ������ ���������, ����� ���������� 0 }
341 { if the string S contains SubWord as the whole word then returns the index of
342 the first such occurrence, otherwise returns 0 }
343
AnsiToOemnull344 function AnsiToOem(const S: String): String;
OemToAnsinull345 function OemToAnsi(const S: String): String;
346
347 procedure AnsiToOemProc(var S: String);
348 procedure OemToAnsiProc(var S: String);
349 {$ENDIF}
350
IsCorrectIdentifiernull351 function IsCorrectIdentifier(const S: String;
352 AcceptIndexes: Boolean{$IFDEF V_DEFAULTS} = False{$ENDIF}): Boolean;
353 { ���������, �������� �� ������ S ���������� ��������������� (�.�. ������
354 �� ����� � ������� �� ��������� ����, ���� � ������� �������������, ������
355 ������ ������ �� �������� ������); ���� AcceptIndexes = True, �� �����������
356 ��������������, ��������, "Pixels[10, 20]" }
357 { checks whether the string S is the correct identifier (i.e. the string is not
358 empty and contains only latin characters, digits and '_' characters, moreover,
359 first character isn't a digit); ; if AcceptIndexes = True then indexing is
360 allowed, e.g. "Pixels[10, 20]" }
361
IsCorrectQualifiedIdentifiernull362 function IsCorrectQualifiedIdentifier(S: String;
363 AcceptIndexes: Boolean{$IFDEF V_DEFAULTS} = False{$ENDIF}): Boolean;
364 { ���������� ������� IsCorrectIdentifier, ������� ��������� �����������������
365 �������������� (��������� ���������������, ���������� �������); ����
366 AcceptIndexes = True, �� ����������� ��������������, ��������,
367 "Canvas.Pixels[10, 20]" }
368 { more general variant of IsCorrectIdentifier which accepts qualified
369 identifiers (several identifiers delimited by dots); if AcceptIndexes = True
370 then indexing is allowed, e.g. "Canvas.Pixels[10, 20]" }
371
RemoveCharnull372 function RemoveChar(const S: String; C: Char): String;
373 {$IFDEF V_WIDESTRINGS}
RemoveCharWidenull374 function RemoveCharWide(const S: WideString; C: WideChar): WideString;
375 {$ENDIF}
376 { ������� �� ������ S ��� �������, ������ C }
377 { removes all characters equal to C from the string S }
378
RemoveCharsnull379 function RemoveChars(const S: String; const CharsToRemove: TCharSet): String;
380 {$IFDEF V_WIDESTRINGS}
RemoveCharsWidenull381 function RemoveCharsWide(const S: WideString; const CharsToRemove: TCharSet): WideString;
382 {$ENDIF}
383 { ������� �� ������ S ��� �������, �������� �� ��������� CharsToRemove }
384 { removes all characters containing in the set CharsToRemove from the string S }
385
RemoveCommentnull386 function RemoveComment(const S: String; CommentPrefix: Char): String;
387 { ������� �� S ����������� - ����� ������, ������� ���������� � CommentPrefix,
388 ������� ���� ������, ���� ������ CommentPrefix �� ��������� ������ ����������
389 ��������, ������������� ���������� ��� �������� ���������; ������� ����������
390 ���������� ����� ������, ������ �� ��� ��������� � �������� ������� �
391 ����������� ������� (������� � ������ <= ' '). ������:
392 RemoveComment('Point="2.0;3.5" ; coordinates', ';') = 'Point="2.0;3.5"' }
393 { removes any comments from the string S; comment is the part of the string
394 starting with CommentPrefix character, including this symbol, if only
395 CommentPrefix isn't located inside the string literal enclosed in the single or
396 double quotes; returns the remaining part of the string with deleted leading
397 and trailing spaces and special characters (characters with codes <= ' ').
398 E.g.: RemoveComment('Point="2.0;3.5" ; coordinates', ';') = 'Point="2.0;3.5"' }
399
StringToLiteralnull400 function StringToLiteral(const S: String): String;
401 {$IFDEF V_WIDESTRINGS}
WideStringToLiteralnull402 function WideStringToLiteral(const S: WideString): WideString;
403 {$ENDIF}
404 { ����������� ������ S � �������, �������� S � ��������� ������� � ��������
405 ��������� �������, �������� � S. ������: 'cause => '''cause' }
406 { converts the string S to the literal enclosing S in the single quotes and
407 duplicating single quotes inside S. E.g.: 'cause => '''cause' }
408
StringToLiteral2null409 function StringToLiteral2(const S: String): String;
410 {$IFDEF V_WIDESTRINGS}
WideStringToLiteral2null411 function WideStringToLiteral2(const S: WideString): WideString;
412 {$ENDIF}
413 { ����������� ������ S � �������, �������� S � ������� ������� � ��������
414 ������� �������, �������� � S. ������: "cause => """cause" }
415 { converts the string S to the literal enclosing S in the double quotes and
416 duplicating double quotes inside S. E.g.: "cause => """cause" }
417
TextToLiteralnull418 function TextToLiteral(const S: String): String;
419 {$IFDEF V_WIDESTRINGS}
WideTextToLiteralnull420 function WideTextToLiteral(const S: WideString): WideString;
421 {$ENDIF}
422 { ���� � ������ S ������ �������, �������� �� ��������� ����, ���� � ���� ������
423 �������� (��. CheckText), ��� S - ������ ������, �� ����������� S � �������,
424 �������� S � ��������� ������� � �������� ��������� �������, �������� � S,
425 ����� ���������� ����� S }
426 { if there are characters differing from the Latin letters, digits and some
427 other characters (see CheckText) in the string S or S is the empty string then
428 converts S to the literal enclosing S in the single quotes and duplicating
429 single quotes inside S, otherwise returns the copy of S }
430
TextToLiteral2null431 function TextToLiteral2(const S: String): String;
432 {$IFDEF V_WIDESTRINGS}
WideTextToLiteral2null433 function WideTextToLiteral2(const S: WideString): WideString;
434 {$ENDIF}
435 { ���� � ������ S ������ �������, �������� �� ��������� ����, ���� � ���� ������
436 �������� (��. CheckText), ��� S - ������ ������, �� ����������� S � �������,
437 �������� S � ������� ������� � �������� ������� �������, �������� � S,
438 ����� ���������� ����� S }
439 { if there are characters differing from the Latin letters, digits and some
440 other characters (see CheckText) in the string S or S is the empty string then
441 converts S to the literal enclosing S in the double quotes and duplicating
442 double quotes inside S, otherwise returns the copy of S }
443
LiteralToStringnull444 function LiteralToString(const S: String): String;
445 {$IFDEF V_WIDESTRINGS}
LiteralToWideStringnull446 function LiteralToWideString(const S: WideString): WideString;
447 {$ENDIF}
448 { �������� ������� � StringToLiteral: ������� ��������� ������� � ������ � �����
449 S, � �� ������ ���� ��������� ������� ������ ������ ��������� ���� �������;
450 ����������� ������������� ������� ������� ������ ��������� (� ���� ������
451 ��������� ������� ���������������� ��� ������� �������, � ������� �������
452 ��������������, ��� ��������� � ������ ������). �������: '''cause' => 'cause;
453 "'cause" => 'cause; """London""" => "London"; "'London'" => 'London'; ���� S
454 �� ��������� � ������� (���������� � ������ � �����), �� ������������ ����� S }
455 { inverse function for StringToLiteral; accepts both single and double quotes.
456 E.g.: '''cause' => 'cause; "'cause" => 'cause; """London""" => "London";
457 "'London'" => 'London'; if the string S isn't enclosed in any quotes (the same
458 at the beginning and at the end of the string) then returns the copy of S }
459
GetValueByNamenull460 function GetValueByName(const S, Name: String; var Value: String;
461 CaseSensitive: Boolean{$IFDEF V_DEFAULTS} = False{$ENDIF};
462 const QuoteChars: TCharSet{$IFDEF V_DEFAULTS} = ['"', '''']{$ENDIF}): Boolean;
463 { in: S = '... Name = XXXX ...'; out: Value = XXXX; example:
464 if S = <META content="text/html; charset=ISO-8859-1" http-equiv=Content-Type>,
465 Name = 'content', QuoteChars = ['"', '''']
466 then
467 Value:='text/html; charset=ISO-8859-1' }
468
469 {$IFDEF V_WIDESTRINGS}{$IFDEF V_D4}{$IFNDEF V_D6} { from Delphi 6 RTL (SysUtils) }
WideFormatBufnull470 function WideFormatBuf(var Buffer; BufLen: Cardinal; const Format;
471 FmtLen: Cardinal; const Args: array of const): Cardinal;
472
473 procedure WideFmtStr(var Result: WideString; const Format: WideString;
474 const Args: array of const);
475
WideFormatnull476 function WideFormat(const Format: WideString; const Args: array of const): WideString;
477 {$ENDIF}{$ENDIF}{$ENDIF}
478
479 {$IFDEF V_D4}
IntToStrSeparatednull480 function IntToStrSeparated(Value: Int64): String;
481 {$ENDIF}
482
IntToRomannull483 function IntToRoman(N: Integer): String;
484 { if N in [1..5000] then converts it to Roman number else returns empty string;
485 from unit QStrings; modified }
486
ValOctPCharnull487 function ValOctPChar(P: PChar; L: Integer; var Value: Integer): Boolean;
ValOctStrnull488 function ValOctStr(const S: String; var Value: Integer): Boolean;
OctToIntnull489 function OctToInt(P: PChar; MaxLen: Integer; var Value: Integer): Boolean;
490
491 const
492 {$IFDEF WIN32}
493 iSystemLocale = LOCALE_SYSTEM_DEFAULT; { $0800: system default locale }
494 iUserLocale = LOCALE_USER_DEFAULT; { $0400: user default locale }
495
496 iCaseInsensitive = NORM_IGNORECASE; { $0001: case-insensitive }
497 iIgnoreNonSpace = NORM_IGNORENONSPACE; { $0002: ignore non-spacing characters }
498 iIgnoreSymbols = NORM_IGNORESYMBOLS; { $0004: ignore symbols }
499 iStringSort = SORT_STRINGSORT; { $1000: use string-order instead of word-order }
500 FlagsMask = iCaseInsensitive or iIgnoreNonSpace or iIgnoreSymbols or iStringSort;
501 {$ELSE}
502 iSystemLocale = $0800; { iSystemLocale and iUserLocale are the same for D1 }
503 iUserLocale = $0400;
504
505 iCaseInsensitive = $0001; { case-insensitive }
506 FlagsMask = iCaseInsensitive;
507 {$ENDIF}
508 LocaleMask = iSystemLocale or iUserLocale;
509
510 { iLocaled: user locale, ascending, case insensitive, word sort order }
511 iLocaled = iUserLocale;
512 { iDefault: don't take into account user locale, ascending, case insensitive,
513 word sort order }
514 iDefault = 0;
515
CmpStrFnull516 function CmpStrF(const S1, S2: String; Flags: LongInt): Integer;
517 { Result value >0 if S1 greater then S2, <0 if S1 less then S2, and 0 if equal.
518 If Flags = 0 then CmpStrF compares S1 and S2 in the same way as if they were
519 compared using "<" and ">" operators.
520 If Flags <> 0 then CmpStrF uses Windows API CompareString function which
521 supports several methods for comparing strings: at first, it can use either
522 System Locale or Current User Locale; then, it can treat strings in the
523 case-sensitive or case-insensitive manner; and, at last, it uses "word sort"
524 or "string sort" variants (see Windows Help for details). Specify the mode you
525 want in the Flags parameter (see constants above). }
526
527 {$IFDEF V_WIDESTRINGS}
WStrCmpnull528 function WStrCmp(PLeft, PRight: PWideChar): Integer;
CompareWidenull529 function CompareWide(const Left, Right: WideString): Integer;
CompareStrBufWidenull530 function CompareStrBufWide(PW1, PW2: PWideChar; Count1, Count2: Integer): Integer;
CompareStrWidenull531 function CompareStrWide(const W1, W2: WideString): Integer;
532 { compare strings case sensitively }
533 {$ENDIF}
534
CompareStrBufnull535 function CompareStrBuf(P1, P2: PChar; Count1, Count2: Integer): Integer;
CompareTextBufnull536 function CompareTextBuf(P1, P2: PChar; Count1, Count2: Integer): Integer;
537
MemEqualStrnull538 function MemEqualStr(const X; const S: String): Boolean;
539
CompareVersionsnull540 function CompareVersions(Ver1, Ver2: String;
541 pError: PBoolean{$IFDEF V_DEFAULTS} = nil{$ENDIF}): Integer;
542 { compares version strings; version string consists of several numbers,
543 delimited by dots ('NN.NN.NN') }
544
545 implementation
546
547 {$IFDEF V_INLINE}
LoCasenull548 function LoCase(C: Char): Char;
549 begin
550 Result:=C;
551 if C in ['A'..'Z'] then
552 Result:=Chr(Ord(Result) or $20);
553 end;
554 {$ELSE}
LoCasenull555 function LoCase(C: Char): Char;
556 {$IFNDEF USE_ASM}
557 begin
558 Result:=C;
559 if C in ['A'..'Z'] then
560 Result:=Chr(Ord(Result) or $20);
561 end;
562 {$ELSE}
563 asm
564 { -> AL Character }
565 { <- AL Result }
566 {$IFDEF V_FREEPASCAL}
567 mov al, C
568 {$ENDIF}
569 CMP AL, 'A'
570 JB @@exit
571 CMP AL, 'Z'
572 JA @@exit
573 ADD AL, 'a' - 'A'
574 @@exit:
575 end;
576 {$ENDIF} {USSE_ASM}
577 {$ENDIF} {V_INLINE}
578
NumOfCharsnull579 function NumOfChars(C: Char; const S: String): Integer;
580 var
581 I: Integer;
582 begin
583 Result:=0;
584 for I:=1 to Length(S) do
585 if S[I] = C then
586 Inc(Result);
587 end;
588
589 {$IFDEF V_WIDESTRINGS}
NumOfWideCharsnull590 function NumOfWideChars(C: WideChar; const S: WideString): Integer;
591 var
592 I: Integer;
593 begin
594 Result:=0;
595 for I:=1 to Length(S) do
596 if S[I] = C then
597 Inc(Result);
598 end;
599 {$ENDIF}
600
NumOfSubStrnull601 function NumOfSubStr(const SubS, S: String): Integer;
602 var
603 I: Integer;
604 begin
605 Result:=0;
606 I:=0;
607 repeat
608 I:=PosFrom(SubS, S, I);
609 if I = 0 then
610 Exit;
611 Inc(Result);
612 Inc(I, Length(SubS));
613 until False;
614 end;
615
616 {$IFDEF V_WIDESTRINGS}
WideNumOfSubStrnull617 function WideNumOfSubStr(const SubS, S: WideString): Integer;
618 var
619 I: Integer;
620 begin
621 Result:=0;
622 I:=0;
623 repeat
624 I:=WidePosFrom(SubS, S, I);
625 if I = 0 then
626 Exit;
627 Inc(Result);
628 Inc(I, Length(SubS));
629 until False;
630 end;
631 {$ENDIF}
632
633 {$IFDEF V_WIDESTRINGS}
WideCharInnull634 function WideCharIn(W: WideChar; const Chars: TCharSet): Boolean;
635 begin
636 Result:=(W < #256) and (Char(W) in Chars);
637 end;
638 {$ENDIF}
639
IsASCIIStringnull640 function IsASCIIString(const S: String): Boolean;
641 var
642 I: Integer;
643 begin
644 for I:=1 to Length(S) do
645 if S[I] >= #128 then begin
646 Result:=False;
647 Exit;
648 end;
649 Result:=True;
650 end;
651
652 {$IFDEF V_WIDESTRINGS}
IsASCIIWideStringnull653 function IsASCIIWideString(const S: WideString): Boolean;
654 var
655 I: Integer;
656 begin
657 for I:=1 to Length(S) do
658 if S[I] >= #128 then begin
659 Result:=False;
660 Exit;
661 end;
662 Result:=True;
663 end;
664 {$ENDIF}
665
CharPosnull666 function CharPos(C: Char; const S: String; From: Integer): Integer;
667 var
668 I, J: Integer;
669 begin
670 if From < 1 then
671 From:=1;
672 {$IFDEF V_LONGSTRINGS}
673 Result:=0;
674 I:=Length(S);
675 if From <= I then begin
676 J:=From - 1;
677 I:=IndexOfValue8((PChar(Pointer(S)) + J)^, Ord(C), I - J);
678 if I >= 0 then
679 Result:=I + From;
680 end;
681 {$ELSE}
682 for I:=From to Length(S) do
683 if S[I] = C then begin
684 Result:=I;
685 Exit;
686 end;
687 Result:=0;
688 {$ENDIF}
689 end;
690
691 {$IFDEF V_WIDESTRINGS}
WideCharPosnull692 function WideCharPos(C: WideChar; const S: WideString; From: Integer): Integer;
693 var
694 I, J: Integer;
695 begin
696 Result:=0;
697 if From < 1 then
698 From:=1;
699 I:=Length(S);
700 if From <= I then begin
701 J:=From - 1;
702 I:=IndexOfValue16((PWideChar(Pointer(S)) + J)^, Ord(C), I - J);
703 if I >= 0 then
704 Result:=I + From;
705 end;
706 end;
707 {$ENDIF}
708
CharNPosnull709 function CharNPos(C: Char; const S: String; N: Integer;
710 From: Integer{$IFDEF V_DEFAULTS} = 1{$ENDIF}): Integer;
711 var
712 I{$IFDEF V_LONGSTRINGS}, J, L{$ENDIF}: Integer;
713 begin
714 if From < 1 then
715 From:=1;
716 {$IFDEF V_LONGSTRINGS}
717 L:=Length(S);
718 while From <= L do begin
719 J:=From - 1;
720 I:=IndexOfValue8((PChar(Pointer(S)) + J)^, Ord(C), L - J);
721 if I < 0 then
722 Break;
723 Dec(N);
724 if N <= 0 then begin
725 Result:=I + From;
726 Exit;
727 end;
728 Inc(From, I + 1);
729 end;
730 Result:=0;
731 {$ELSE}
732 for I:=From to Length(S) do
733 if S[I] = C then begin
734 Dec(N);
735 if N <= 0 then begin
736 Result:=I;
737 Exit;
738 end;
739 end;
740 Result:=0;
741 {$ENDIF}
742 end;
743
744 {$IFDEF V_WIDESTRINGS}
WideCharNPosnull745 function WideCharNPos(C: WideChar; const S: WideString; N: Integer;
746 From: Integer{$IFDEF V_DEFAULTS} = 1{$ENDIF}): Integer;
747 var
748 I, J, L: Integer;
749 begin
750 if From < 1 then
751 From:=1;
752 L:=Length(S);
753 while From <= L do begin
754 J:=From - 1;
755 I:=IndexOfValue16((PWideChar(Pointer(S)) + J)^, Ord(C), L - J);
756 if I < 0 then
757 Break;
758 Dec(N);
759 if N <= 0 then begin
760 Result:=I + From;
761 Exit;
762 end;
763 Inc(From, I + 1);
764 end;
765 Result:=0;
766 end;
767 {$ENDIF}
768
LastPosnull769 function LastPos(C: Char; const S: String): Integer;
770 var
771 I: Integer;
772 begin
773 Result:=0;
774 for I:=Length(S) downto 1 do
775 if S[I] = C then begin
776 Result:=I;
777 Exit;
778 end;
779 end;
780
781 {$IFDEF V_WIDESTRINGS}
WideLastPosnull782 function WideLastPos(C: WideChar; const S: WideString): Integer;
783 var
784 I: Integer;
785 begin
786 Result:=0;
787 for I:=Length(S) downto 1 do
788 if S[I] = C then begin
789 Result:=I;
790 Exit;
791 end;
792 end;
793 {$ENDIF}
794
CharInSetPosnull795 function CharInSetPos(const Chars: TCharSet; const S: String; From: Integer): Integer;
796 var
797 I: Integer;
798 begin
799 if From < 1 then
800 From:=1;
801 for I:=From to Length(S) do
802 if S[I] in Chars then begin
803 Result:=I;
804 Exit;
805 end;
806 Result:=0;
807 end;
808
809 {$IFDEF V_WIDESTRINGS}
WideCharInSetPosnull810 function WideCharInSetPos(const Chars: TCharSet; const S: WideString; From: Integer): Integer;
811 var
812 I: Integer;
813 W: WideChar;
814 begin
815 if From < 1 then
816 From:=1;
817 for I:=From to Length(S) do begin
818 W:=S[I];
819 if (W < #256) and (Char(W) in Chars) then begin
820 Result:=I;
821 Exit;
822 end;
823 end;
824 Result:=0;
825 end;
826 {$ENDIF}
827
CharNotInSetPosnull828 function CharNotInSetPos(const Chars: TCharSet; const S: String; From: Integer): Integer;
829 var
830 I: Integer;
831 begin
832 if From < 1 then
833 From:=1;
834 for I:=From to Length(S) do
835 if not (S[I] in Chars) then begin
836 Result:=I;
837 Exit;
838 end;
839 Result:=0;
840 end;
841
842 {$IFDEF V_WIDESTRINGS}
WideCharNotInSetPosnull843 function WideCharNotInSetPos(const Chars: TCharSet; const S: WideString; From: Integer): Integer;
844 var
845 I: Integer;
846 W: WideChar;
847 begin
848 if From < 1 then
849 From:=1;
850 for I:=From to Length(S) do begin
851 W:=S[I];
852 if (W >= #256) or not (Char(W) in Chars) then begin
853 Result:=I;
854 Exit;
855 end;
856 end;
857 Result:=0;
858 end;
859 {$ENDIF}
860
861 {$IFDEF V_WIN}
AnsiTextPosnull862 function AnsiTextPos(const SubS, S: String): Integer;
863 begin
864 Result:=Pos(AnsiUpperCase(SubS), AnsiUpperCase(S));
865 end;
866 {$ENDIF}
867
FirstUppernull868 function FirstUpper(const S: String): String;
869 begin
870 Result:=S;
871 FirstUpperProc(Result);
872 end;
873
874 procedure FirstUpperProc(var S: String);
875 {$IFDEF V_WIN}
876 var
877 Buf: array [0..1] of Char;
878 {$ENDIF}
879 begin
880 if S <> '' then begin
881 {$IFDEF V_WIN}
882 Buf[0]:=S[1];
883 Buf[1]:=#0;
884 {$IFDEF WIN32}
885 CharUpper(Buf);
886 {$ELSE}
887 AnsiUpper(Buf);
888 {$ENDIF}
889 S[1]:=Buf[0];
890 {$ELSE}
891 S[1]:=UpCase(S[1]);
892 {$ENDIF}
893 end;
894 end;
895
FirstLowernull896 function FirstLower(const S: String): String;
897 begin
898 Result:=S;
899 FirstLowerProc(Result);
900 end;
901
902 procedure FirstLowerProc(var S: String);
903 {$IFDEF V_WIN}
904 var
905 Buf: array [0..1] of Char;
906 {$ENDIF}
907 begin
908 if S <> '' then begin
909 {$IFDEF V_WIN}
910 Buf[0]:=S[1];
911 Buf[1]:=#0;
912 {$IFDEF WIN32}
913 CharLower(Buf);
914 {$ELSE}
915 AnsiLower(Buf);
916 {$ENDIF}
917 S[1]:=Buf[0];
918 {$ELSE}
919 S[1]:=LoCase(S[1]);
920 {$ENDIF}
921 end;
922 end;
923
DelLastNnull924 function DelLastN(const S: String; N: Integer): String;
925 begin
926 N:=Length(S) - N;
927 if N > 0 then
928 Result:=Copy(S, 1, N)
929 else
930 Result:='';
931 end;
932
DelLastIfnull933 function DelLastIf(const S: String; C: Char): String;
934 begin
935 Result:=S;
936 if (S <> '') and (S[Length(S)] = C) then
937 SetLength(Result, Length(S) - 1);
938 end;
939
FirstCharnull940 function FirstChar(const S: String): Char;
941 begin
942 Result:=#0;
943 if S <> '' then
944 Result:=S[1];
945 end;
946
LastCharnull947 function LastChar(const S: String): Char;
948 begin
949 Result:=#0;
950 if S <> '' then
951 Result:=S[Length(S)];
952 end;
953
954 {$IFDEF V_WIDESTRINGS}
WideFirstCharnull955 function WideFirstChar(const S: WideString): WideChar;
956 begin
957 Result:=#0;
958 if S <> '' then
959 Result:=S[1];
960 end;
961
WideLastCharnull962 function WideLastChar(const S: WideString): WideChar;
963 begin
964 Result:=#0;
965 if S <> '' then
966 Result:=S[Length(S)];
967 end;
968 {$ENDIF}
969
EnsureLastnull970 function EnsureLast(const S: String; C: Char): String;
971 var
972 L: Integer;
973 begin
974 Result:=S;
975 L:=Length(S);
976 if (L > 0) and (S[L] <> C) then
977 Result:=Result + C;
978 end;
979
980 {$IFDEF V_WIDESTRINGS}
WideEnsureLastnull981 function WideEnsureLast(const S: WideString; C: WideChar): WideString;
982 var
983 L: Integer;
984 begin
985 Result:=S;
986 L:=Length(Result);
987 if (L > 0) and (Result[L] <> C) then begin
988 Inc(L);
989 SetLength(Result, L);
990 Result[L]:=C;
991 end;
992 end;
993 {$ENDIF}
994
CloseSentencenull995 function CloseSentence(const S: String): String;
996 begin
997 Result:=S;
998 CloseSentenceProc(Result);
999 end;
1000
1001 procedure CloseSentenceProc(var S: String);
1002 begin
1003 if (S <> '') and not (S[Length(S)] in ['.', '!', '?']) then
1004 S:=S + '.';
1005 end;
1006
1007 {$IFDEF V_WIDESTRINGS}
WideCloseSentencenull1008 function WideCloseSentence(const S: WideString): WideString;
1009 begin
1010 Result:=S;
1011 WideCloseSentenceProc(Result);
1012 end;
1013
1014 procedure WideCloseSentenceProc(var S: WideString);
1015 var
1016 WC: WideChar;
1017 begin
1018 if S <> '' then begin
1019 WC:=S[Length(S)];
1020 if not ((WC < #256) and (Char(WC) in ['.', '!', '?'])) then
1021 S:=S + '.';
1022 end;
1023 end;
1024 {$ENDIF}
1025
1026 procedure ConcatDelimited(var S: String; const Tail: String; Delimiter: Char);
1027 begin
1028 if Tail <> '' then begin
1029 if S <> '' then
1030 S:=S + Delimiter;
1031 S:=S + Tail;
1032 end;
1033 end;
1034
1035 {$IFDEF V_WIDESTRINGS}
1036 procedure WideConcatDelimited(var S: WideString; const Tail: WideString; Delimiter: WideChar);
1037 begin
1038 if Tail <> '' then begin
1039 {$IFDEF V_WIDESTRING_PLUS}
1040 if S <> '' then
1041 S:=S + Delimiter;
1042 S:=S + Tail;
1043 {$ELSE}
1044 if S <> '' then
1045 WideAppend(S, Delimiter);
1046 WideAppendStr(S, Tail);
1047 {$ENDIF}
1048 end;
1049 end;
1050 {$ENDIF}
1051
1052 {$IFDEF V_WIDESTRINGS}
1053 procedure WideAppend(var S: WideString; C: WideChar);
1054 var
1055 L: Integer;
1056 begin
1057 L:=Length(S) + 1;
1058 SetLength(S, L);
1059 S[L]:=C;
1060 end;
1061
1062 procedure WideAppendStr(var S: WideString; const Tail: WideString);
1063 var
1064 L, T: Integer;
1065 begin
1066 T:=Length(Tail);
1067 if T = 0 then
1068 Exit;
1069 L:=Length(S);
1070 if L = 0 then
1071 S:=Tail
1072 else begin
1073 SetLength(S, L + T);
1074 Move(Pointer(Tail)^, PWideChar(Pointer(S))[L], T * 2);
1075 end;
1076 end;
1077 {$ENDIF}
1078
PosFromnull1079 function PosFrom(const SubStr, S: String; From: Integer): Integer;
1080 begin
1081 if From < 1 then
1082 From:=1;
1083 Result:=Pos(SubStr, Copy(S, From, Length(S)));
1084 if Result > 0 then
1085 Inc(Result, From - 1);
1086 end;
1087
1088 {$IFDEF V_WIDESTRINGS}
WidePosFromnull1089 function WidePosFrom(const SubStr, S: WideString; From: Integer): Integer;
1090 begin
1091 if From < 1 then
1092 From:=1;
1093 Result:=Pos(SubStr, Copy(S, From, Length(S)));
1094 if Result > 0 then
1095 Inc(Result, From - 1);
1096 end;
1097 {$ENDIF}
1098
StartsWithnull1099 function StartsWith(const S, What: String): Boolean;
1100 var
1101 I, L: Integer;
1102 begin
1103 Result:=False;
1104 L:=Length(What);
1105 if L > Length(S) then
1106 Exit;
1107 for I:=1 to L do
1108 if S[I] <> What[I] then
1109 Exit;
1110 Result:=True;
1111 end;
1112
1113 {$IFDEF V_WIDESTRINGS}
WideStartsWithnull1114 function WideStartsWith(const S, What: WideString): Boolean;
1115 var
1116 I, L: Integer;
1117 begin
1118 Result:=False;
1119 L:=Length(What);
1120 if L > Length(S) then
1121 Exit;
1122 for I:=1 to L do
1123 if S[I] <> What[I] then
1124 Exit;
1125 Result:=True;
1126 end;
1127 {$ENDIF}
1128
AnsiStartsWithnull1129 function AnsiStartsWith(const S, What: String): Boolean;
1130 var
1131 L: Integer;
1132 begin
1133 Result:=False;
1134 L:=Length(What);
1135 if L > Length(S) then
1136 Exit;
1137 Result:=AnsiSameText(Copy(S, 1, L), What);
1138 end;
1139
EndsWithnull1140 function EndsWith(const S, What: String): Boolean;
1141 var
1142 I, J, N, L: Integer;
1143 begin
1144 Result:=False;
1145 L:=Length(S);
1146 N:=L - Length(What);
1147 if N < 0 then
1148 Exit;
1149 J:=1;
1150 for I:=N + 1 to L do begin
1151 if S[I] <> What[J] then
1152 Exit;
1153 Inc(J);
1154 end;
1155 Result:=True;
1156 end;
1157
1158 {$IFDEF V_WIDESTRINGS}
WideEndsWithnull1159 function WideEndsWith(const S, What: WideString): Boolean;
1160 var
1161 I, J, N, L: Integer;
1162 begin
1163 Result:=False;
1164 L:=Length(S);
1165 N:=L - Length(What);
1166 if N < 0 then
1167 Exit;
1168 J:=1;
1169 for I:=N + 1 to L do begin
1170 if S[I] <> What[J] then
1171 Exit;
1172 Inc(J);
1173 end;
1174 Result:=True;
1175 end;
1176 {$ENDIF}
1177
1178 {$IFDEF V_DELPHI}
1179 {$IFNDEF V_D3}
Trimnull1180 function Trim(const S: String): String;
1181 {$ELSE}
TrimWnull1182 function TrimW(const S: WideString): WideString;
1183 {$ENDIF}
1184 var
1185 I, J: Integer;
1186 begin
1187 I:=1;
1188 while (I <= Length(S)) and (S[I] <= ' ') do Inc(I);
1189 J:=Length(S);
1190 while (J >= 1) and (S[J] <= ' ') do Dec(J);
1191 Result:=Copy(S, I, J - I + 1)
1192 end;
1193 {$ENDIF}
1194
1195 {$IFNDEF V_D5} { Delphi 1-4, Free Pascal }
AnsiSameTextnull1196 function AnsiSameText(const S1, S2: String): Boolean;
1197 begin
1198 {$IFDEF WIN32}
1199 Result:=CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PChar(S1),
1200 Length(S1), PChar(S2), Length(S2)) = 2;
1201 {$ELSE}
1202 Result:=AnsiCompareText(S1, S2) = 0;
1203 {$ENDIF}
1204 end;
1205 {$ENDIF}
1206
1207 {$IFDEF V_WIDESTRINGS}
1208 {$IFNDEF V_D6}
WideCompareTextnull1209 function WideCompareText(const S1, S2: WideString): Integer;
1210 begin
1211 {$IFDEF MSWINDOWS}
1212 SetLastError(0);
1213 Result:=CompareStringW(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PWideChar(S1),
1214 Length(S1), PWideChar(S2), Length(S2)) - 2;
1215 Case GetLastError of
1216 0: ;
1217 ERROR_CALL_NOT_IMPLEMENTED:
1218 Result:=CompareStringA(LOCALE_USER_DEFAULT, NORM_IGNORECASE,
1219 PChar(String(S1)), Length(S1), PChar(String(S2)), Length(S2)) - 2;
1220 Else
1221 RaiseLastOSError;
1222 End;
1223 {$ENDIF}
1224 {$IFDEF UNIX}
1225 Result:=WideCompareStr(WideUpperCase(S1), WideUpperCase(S2));
1226 {$ENDIF}
1227 end;
1228
WideSameTextnull1229 function WideSameText(const S1, S2: WideString): Boolean;
1230 begin
1231 Result:=WideCompareText(S1, S2) = 0;
1232 end;
1233 {$ENDIF}
1234 {$ENDIF}
1235
TrimTrailnull1236 function TrimTrail(const S: String): String;
1237 var
1238 I: Integer;
1239 begin
1240 I:=Length(S);
1241 while (I >= 1) and (S[I] <= ' ') do Dec(I);
1242 Result:=S;
1243 SetLength(Result, I);
1244 end;
1245
1246 {$IFDEF V_WIDESTRINGS}
TrimTrailWnull1247 function TrimTrailW(const S: WideString): WideString;
1248 var
1249 I: Integer;
1250 begin
1251 I:=Length(S);
1252 while (I >= 1) and (S[I] <= ' ') do Dec(I);
1253 Result:=S;
1254 SetLength(Result, I);
1255 end;
1256 {$ENDIF}
1257
TruncateAtZeronull1258 function TruncateAtZero(const S: String): String;
1259 begin
1260 Result:=S;
1261 TruncateAtZeroProc(Result);
1262 end;
1263
1264 procedure TruncateAtZeroProc(var S: String);
1265 var
1266 I: Integer;
1267 begin
1268 I:=CharPos(#0, S, 1);
1269 if I > 0 then
1270 SetLength(S, I - 1);
1271 end;
1272
1273 {$IFDEF V_WIDESTRINGS}
TruncateAtZeroWidenull1274 function TruncateAtZeroWide(const S: WideString): WideString;
1275 begin
1276 Result:=S;
1277 TruncateAtZeroProcWide(Result);
1278 end;
1279
1280 procedure TruncateAtZeroProcWide(var S: WideString);
1281 var
1282 I: Integer;
1283 begin
1284 I:=WideCharPos(#0, S, 1);
1285 if I > 0 then
1286 SetLength(S, I - 1);
1287 end;
1288 {$ENDIF}
1289
TrimLastNnull1290 function TrimLastN(const S: String; N: Integer): String;
1291 var
1292 L: Integer;
1293 begin
1294 L:=Length(S) - N;
1295 if L < 0 then
1296 L:=0;
1297 Result:=Copy(S, 1, L);
1298 end;
1299
1300 procedure TrimLastNProc(var S: String; N: Integer);
1301 var
1302 L: Integer;
1303 begin
1304 L:=Length(S) - N;
1305 if L < 0 then
1306 L:=0;
1307 SetLength(S, L);
1308 end;
1309
1310 {$IFDEF V_WIDESTRINGS}
WideTrimLastNnull1311 function WideTrimLastN(const S: WideString; N: Integer): WideString;
1312 var
1313 L: Integer;
1314 begin
1315 L:=Length(S) - N;
1316 if L < 0 then
1317 L:=0;
1318 Result:=Copy(S, 1, L);
1319 end;
1320
1321 procedure WideTrimLastNProc(var S: WideString; N: Integer);
1322 var
1323 L: Integer;
1324 begin
1325 L:=Length(S) - N;
1326 if L < 0 then
1327 L:=0;
1328 SetLength(S, L);
1329 end;
1330 {$ENDIF}
1331
IsWhiteSpacenull1332 function IsWhiteSpace(const S: String): Boolean;
1333 var
1334 I: Integer;
1335 begin
1336 for I:=1 to Length(S) do
1337 if S[I] > ' ' then begin
1338 Result:=False;
1339 Exit;
1340 end;
1341 Result:=True;
1342 end;
1343
MakeStringnull1344 function MakeString(C: Char; N: Integer): String;
1345 begin
1346 if N > 0 then begin
1347 {$IFDEF V_LONGSTRINGS}
1348 SetLength(Result, N);
1349 {$ELSE}
1350 if N > 255 then
1351 N:=255;
1352 Result[0]:=Chr(N);
1353 {$ENDIF}
1354 FillChar(Result[1], Length(Result), C);
1355 end
1356 else
1357 Result:='';
1358 end;
1359
1360 {$IFDEF V_WIDESTRINGS}
MakeWideStringnull1361 function MakeWideString(C: WideChar; N: Integer): WideString;
1362 begin
1363 SetLength(Result, N);
1364 if N > 0 then
1365 FillValue16(Result[1], Int16(C), N);
1366 end;
1367 {$ENDIF}
1368
AddCharnull1369 function AddChar(C: Char; const S: String; N: Integer): String;
1370 begin
1371 if Length(S) < N then
1372 Result:=MakeString(C, N - Length(S)) + S
1373 else
1374 Result := S;
1375 end;
1376
ReplaceStrnull1377 function ReplaceStr(const Value, FromStr, ToStr: String): String;
1378 var
1379 I: Integer;
1380 Source: String;
1381 begin
1382 Source:=Value;
1383 Result:='';
1384 repeat
1385 I:=Pos(FromStr, Source);
1386 if I > 0 then begin
1387 Result:=Result + Copy(Source, 1, I - 1) + ToStr;
1388 Source:=Copy(Source, I + Length(FromStr), Length(Source));
1389 end
1390 else begin
1391 Result:=Result + Source;
1392 Break;
1393 end;
1394 until False;
1395 end;
1396
1397 {$IFDEF V_WIDESTRINGS}
WideReplaceStrnull1398 function WideReplaceStr(const Value, FromStr, ToStr: WideString): WideString;
1399 var
1400 I: Integer;
1401 Source: WideString;
1402 begin
1403 Source:=Value;
1404 Result:='';
1405 repeat
1406 I:=Pos(FromStr, Source);
1407 if I > 0 then begin
1408 Result:=Result + Copy(Source, 1, I - 1) + ToStr;
1409 Source:=Copy(Source, I + Length(FromStr), Length(Source));
1410 end
1411 else begin
1412 Result:=Result + Source;
1413 Break;
1414 end;
1415 until False;
1416 end;
1417 {$ENDIF}
1418
1419 procedure ReplaceCharProc(var S: String; FromChar, ToChar: Char);
1420 var
1421 I: Integer;
1422 begin
1423 for I:=1 to Length(S) do
1424 if S[I] = FromChar then
1425 S[I]:=ToChar;
1426 end;
1427
ReplaceCharnull1428 function ReplaceChar(const S: String; FromChar, ToChar: Char): String;
1429 begin
1430 Result:=S;
1431 ReplaceCharProc(Result, FromChar, ToChar);
1432 end;
1433
1434 {$IFDEF V_WIDESTRINGS}
1435 procedure WideReplaceCharProc(var S: WideString; FromChar, ToChar: WideChar);
1436 var
1437 I: Integer;
1438 begin
1439 for I:=1 to Length(S) do
1440 if S[I] = FromChar then
1441 S[I]:=ToChar;
1442 end;
1443
WideReplaceCharnull1444 function WideReplaceChar(const S: WideString; FromChar, ToChar: WideChar): WideString;
1445 begin
1446 Result:=S;
1447 WideReplaceCharProc(Result, FromChar, ToChar);
1448 end;
1449 {$ENDIF}
1450
ContainsCharsnull1451 function ContainsChars(const S: String; Chars: TCharSet): Boolean;
1452 { alternative:
1453 Result:=ContainsCharsBuf(PChar(S), Length(S), Chars); }
1454 var
1455 I: Integer;
1456 begin
1457 for I:=1 to Length(S) do
1458 if S[I] in Chars then begin
1459 Result:=True;
1460 Exit;
1461 end;
1462 Result:=False;
1463 end;
1464
ContainsCharsBufnull1465 function ContainsCharsBuf(const Buf: PChar; Size: Integer;
1466 const Chars: TCharSet): Boolean;
1467 var
1468 P, Limit: PChar;
1469 begin
1470 Result:=False;
1471 if (Buf = nil) or (Size <= 0) then
1472 Exit;
1473 P:=Buf;
1474 Limit:=Buf + Size;
1475 repeat
1476 if P^ in Chars then begin
1477 Result:=True;
1478 Exit;
1479 end;
1480 Inc(P);
1481 until P >= Limit;
1482 end;
1483
1484 {$IFDEF V_WIDESTRINGS}
WideContainsCharsnull1485 function WideContainsChars(const S: WideString; Chars: TCharSet): Boolean;
1486 var
1487 I: Integer;
1488 C: WideChar;
1489 begin
1490 for I:=1 to Length(S) do begin
1491 C:=S[I];
1492 if (C < #256) and (Char(C) in Chars) then begin
1493 Result:=True;
1494 Exit;
1495 end;
1496 end;
1497 Result:=False;
1498 end;
1499 {$ENDIF}
1500
ContainsOnlyCharsnull1501 function ContainsOnlyChars(const S: String; const Chars: TCharSet): Boolean;
1502 { alternative:
1503 Result:=ContainsOnlyCharsBuf(PChar(S), Length(S), Chars); }
1504 var
1505 I: Integer;
1506 begin
1507 Result:=False;
1508 if S = '' then
1509 Exit;
1510 for I:=1 to Length(S) do
1511 if not (S[I] in Chars) then
1512 Exit;
1513 Result:=True;
1514 end;
1515
ContainsOnlyCharsBufnull1516 function ContainsOnlyCharsBuf(const Buf: PChar; Size: Integer;
1517 const Chars: TCharSet): Boolean;
1518 var
1519 P, Limit: PChar;
1520 begin
1521 Result:=False;
1522 if (Buf = nil) or (Size <= 0) then
1523 Exit;
1524 P:=Buf;
1525 Limit:=Buf + Size;
1526 repeat
1527 if not (P^ in Chars) then
1528 Exit;
1529 Inc(P);
1530 until P >= Limit;
1531 Result:=True;
1532 end;
1533
DelDupCharnull1534 function DelDupChar(const S: String; C: Char): String;
1535 var
1536 I, J: Integer;
1537 CurChar, LastChar: Char;
1538 begin
1539 SetLength(Result, Length(S));
1540 if Length(S) > 0 then begin
1541 LastChar:=S[1];
1542 Result[1]:=LastChar;
1543 J:=1;
1544 for I:=2 to Length(S) do begin
1545 CurChar:=S[I];
1546 if (CurChar <> C) or (CurChar <> LastChar) then begin
1547 Inc(J);
1548 Result[J]:=CurChar;
1549 LastChar:=CurChar;
1550 end;
1551 end;
1552 SetLength(Result, J);
1553 end;
1554 end;
1555
1556 {$IFDEF V_LONGSTRINGS}
DecodeCEscapesnull1557 function DecodeCEscapes(const S: String): String;
1558 var
1559 State: (sNeutral, sWasSlash, sOct, sHex);
1560
ConvertToNumbernull1561 function ConvertToNumber(S: String; var Num: Integer): Boolean;
1562 var
1563 I, J, Code: Integer;
1564 begin
1565 Result:=False;
1566 if State = sHex then begin
1567 Val(S, J, Code);
1568 if (Code <> 0) or (J > 255) then
1569 Exit;
1570 end
1571 else begin
1572 J:=0;
1573 for I:=1 to Length(S) do begin
1574 Code:=Ord(S[I]) - Ord('0');
1575 if (Code < 0) or (Code > 7) then
1576 Exit;
1577 J:=J * 8 + Code;
1578 if J > 255 then
1579 Exit;
1580 end;
1581 end;
1582 Num:=J;
1583 Result:=True;
1584 end;
1585
1586 var
1587 I, J, CharCode: Integer;
1588 C: Char;
1589 InP, OutP, InLimit: PChar;
1590 Number: String;
1591 begin
1592 I:=CharPos('\', S, 1);
1593 if I = 0 then
1594 Result:=S
1595 else begin
1596 CharCode:=-1;
1597 State:=sWasSlash;
1598 J:=I - 1;
1599 Result:=Copy(S, 1, J);
1600 InP:=PChar(Pointer(S)) + I;
1601 I:=Length(S);
1602 InLimit:=PChar(Pointer(S)) + I;
1603 SetLength(Result, I);
1604 OutP:=PChar(Pointer(Result)) + J;
1605 while InP < InLimit do begin
1606 C:=InP^;
1607 Case State of
1608 sNeutral: begin
1609 if C <> '\' then begin
1610 OutP^:=C;
1611 Inc(OutP);
1612 end
1613 else
1614 State:=sWasSlash;
1615 Inc(InP);
1616 end;
1617 sWasSlash: begin
1618 Case C of
1619 '0'..'7': begin
1620 Number:=C;
1621 CharCode:=Ord(C) - Ord('0');
1622 State:=sOct;
1623 Inc(InP);
1624 Continue;
1625 end;
1626 'a': C:=#7;
1627 'b': C:=#8;
1628 'f': C:=#$0C;
1629 'n': begin
1630 OutP^:=#$0D;
1631 Inc(OutP);
1632 C:=#$0A;
1633 end;
1634 'r': C:=#$0D;
1635 't': C:=#9;
1636 'v': C:=#$0B;
1637 '\', '''', '"', '?': ; // C:=C
1638 'x': begin
1639 Number:='$';
1640 State:=sHex;
1641 Inc(InP);
1642 Continue;
1643 end;
1644 Else begin
1645 OutP^:='\';
1646 Inc(OutP);
1647 end;
1648 End;
1649 OutP^:=C;
1650 Inc(InP);
1651 Inc(OutP);
1652 State:=sNeutral;
1653 end;
1654 sOct, sHex: begin
1655 Number:=Number + C;
1656 if ConvertToNumber(Number, CharCode) then
1657 Inc(InP)
1658 else begin
1659 if CharCode >= 0 then begin
1660 OutP^:=Chr(CharCode);
1661 CharCode:=-1;
1662 end
1663 else begin
1664 OutP^:='\';
1665 if State = sHex then begin
1666 Inc(OutP);
1667 OutP^:='x';
1668 end;
1669 end;
1670 Inc(OutP);
1671 State:=sNeutral;
1672 end;
1673 end;
1674 End;
1675 end; {while}
1676 Case State of
1677 sOct, sHex:
1678 if CharCode >= 0 then begin
1679 OutP^:=Chr(CharCode);
1680 Inc(OutP);
1681 end;
1682 sWasSlash: begin
1683 OutP^:='\';
1684 Inc(OutP);
1685 end;
1686 End;
1687 SetLength(Result, OutP - PChar(Pointer(Result)));
1688 end;
1689 end;
1690
EncodeCEscapesnull1691 function EncodeCEscapes(const S: String; Only7Bit: Boolean): String;
1692 var
1693 I, L: Integer;
1694 C, Slash: Char;
1695 OutP: PChar;
1696 Hex: String[2];
1697 begin
1698 L:=Length(S);
1699 SetLength(Result, 4 * L);
1700 OutP:=Pointer(Result);
1701 I:=1;
1702 while I <= L do begin
1703 C:=S[I];
1704 Case C of
1705 #7: Slash:='a';
1706 #8: Slash:='b';
1707 #9: Slash:='t';
1708 #$0B: Slash:='v';
1709 #$0C: Slash:='f';
1710 #$0D:
1711 if (I < L) and (S[I + 1] = #$0A) then begin
1712 Slash:='n';
1713 Inc(I);
1714 end
1715 else
1716 Slash:='r';
1717 '\', '''', '"', '?': Slash:=C;
1718 Else begin
1719 Slash:=#0;
1720 if (C < ' ') or Only7Bit and (C >= #128) then
1721 if C < #8 then
1722 Slash:=Chr(Ord(C) + Ord('0'))
1723 else begin
1724 OutP^:='\';
1725 Inc(OutP);
1726 OutP^:='x';
1727 Inc(OutP);
1728 Hex:=IntToHex(Ord(C), 0);
1729 OutP^:=Hex[1];
1730 Inc(OutP);
1731 if Length(Hex) > 1 then begin
1732 OutP^:=Hex[2];
1733 Inc(OutP);
1734 end;
1735 end
1736 else begin
1737 OutP^:=C;
1738 Inc(OutP);
1739 end;
1740 end;
1741 End;
1742 if Slash <> #0 then begin
1743 OutP^:='\';
1744 Inc(OutP);
1745 OutP^:=Slash;
1746 Inc(OutP);
1747 end;
1748 Inc(I);
1749 end; {while}
1750 SetLength(Result, OutP - PChar(Pointer(Result)));
1751 end;
1752 {$ENDIF}
1753
1754 {$IFDEF WIN32}
WordPosnull1755 function WordPos(SubWord, S: String; CaseSensitive: Boolean): Integer;
1756 var
1757 LSub, LStr: Integer;
1758 P, PSub, PStr, Limit: PChar;
1759 begin
1760 Result:=0;
1761 LSub:=Length(SubWord);
1762 LStr:=Length(S);
1763 if (LSub = 0) or (LSub > LStr) then
1764 Exit;
1765 if not CaseSensitive then begin
1766 UniqueString(SubWord);
1767 CharUpperBuff(Pointer(SubWord), LSub);
1768 UniqueString(S);
1769 CharUpperBuff(Pointer(S), LStr);
1770 end;
1771 PSub:=Pointer(SubWord);
1772 PStr:=Pointer(S);
1773 P:=PStr;
1774 Limit:=PStr + LStr;
1775 repeat
1776 P:=StrPos(P, PSub);
1777 if P = nil then
1778 Exit;
1779 if ((P = PStr) or not IsCharAlphaNumeric((P - 1)^)) and
1780 ((P + LSub >= Limit) or not IsCharAlphaNumeric((P + LSub)^))
1781 then
1782 Break;
1783 Inc(P);
1784 until P >= Limit;
1785 Result:=P - PStr + 1;
1786 end;
1787
AnsiToOemnull1788 function AnsiToOem(const S: String): String;
1789 begin
1790 SetLength(Result, Length(S));
1791 if S <> '' then
1792 CharToOEM(Pointer(S), Pointer(Result));
1793 end;
1794
OemToAnsinull1795 function OemToAnsi(const S: String): String;
1796 begin
1797 SetLength(Result, Length(S));
1798 if S <> '' then
1799 OemToChar(Pointer(S), Pointer(Result));
1800 end;
1801
1802 procedure AnsiToOemProc(var S: String);
1803 begin
1804 UniqueString(S);
1805 CharToOEM(Pointer(S), Pointer(S));
1806 end;
1807
1808 procedure OemToAnsiProc(var S: String);
1809 begin
1810 UniqueString(S);
1811 OEMToChar(Pointer(S), Pointer(S));
1812 end;
1813 {$ENDIF}
1814
IsCorrectIdentifiernull1815 function IsCorrectIdentifier(const S: String; AcceptIndexes: Boolean): Boolean;
1816 var
1817 I, J, K, L, M, LT: Integer;
1818 T, Indexes: String;
1819 begin
1820 Result:=False;
1821 if S <> '' then begin
1822 if S[1] in Digits then
1823 Exit;
1824 L:=Length(S);
1825 if AcceptIndexes then begin
1826 I:=CharPos('[', S, 1);
1827 if I > 0 then begin
1828 if S[L] <> ']' then
1829 Exit;
1830 Indexes:=Copy(S, I + 1, L - (I + 1));
1831 repeat
1832 J:=CharPos(',', Indexes, 1);
1833 if J > 0 then
1834 T:=Copy(Indexes, 1, J - 1)
1835 else
1836 T:=Indexes;
1837 K:=0;
1838 LT:=Length(T);
1839 repeat
1840 Inc(K);
1841 if K > LT then
1842 Exit;
1843 until T[K] <> ' ';
1844 while (LT > 0) and (T[LT] = ' ') do
1845 Dec(LT);
1846 for M:=K to LT do
1847 if not (T[M] in Digits) then
1848 Exit;
1849 if J = 0 then
1850 Break;
1851 Delete(Indexes, 1, J);
1852 until False;
1853 L:=I - 1;
1854 end;
1855 end;
1856 for I:=1 to L do
1857 if not (S[I] in ASCIIAlphaNumeric + ['_']) then
1858 Exit;
1859 Result:=True;
1860 end;
1861 end;
1862
IsCorrectQualifiedIdentifiernull1863 function IsCorrectQualifiedIdentifier(S: String; AcceptIndexes: Boolean): Boolean;
1864 var
1865 I: Integer;
1866 begin
1867 repeat
1868 I:=CharPos('.', S, 1);
1869 if I = 0 then begin
1870 Result:=IsCorrectIdentifier(S, AcceptIndexes);
1871 Exit;
1872 end;
1873 if not IsCorrectIdentifier(Copy(S, 1, I - 1), AcceptIndexes) then
1874 Break;
1875 Delete(S, 1, I);
1876 until False;
1877 Result:=False;
1878 end;
1879
RemoveCharnull1880 function RemoveChar(const S: String; C: Char): String;
1881 var
1882 L: Integer;
1883 P1, P2, Limit: PChar;
1884 begin
1885 L:=Length(S);
1886 P1:={$IFDEF V_LONGSTRINGS}Pointer(S){$ELSE}@S[1]{$ENDIF};
1887 SetLength(Result, L);
1888 P2:={$IFDEF V_LONGSTRINGS}Pointer(Result){$ELSE}@Result[1]{$ENDIF};
1889 Limit:=P1 + L;
1890 while P1 < Limit do begin
1891 if P1^ <> C then begin
1892 P2^:=P1^;
1893 Inc(P2);
1894 end;
1895 Inc(P1);
1896 end; {while}
1897 SetLength(Result,
1898 {$IFNDEF V_FREEPASCAL}
1899 P2 - {$IFDEF V_LONGSTRINGS}Pointer(Result){$ELSE}@Result[1]{$ENDIF}
1900 {$ELSE}
1901 Cardinal(P2) - Cardinal(Pointer(Result))
1902 {$ENDIF}
1903 );
1904 end;
1905
1906 {$IFDEF V_WIDESTRINGS}
RemoveCharWidenull1907 function RemoveCharWide(const S: WideString; C: WideChar): WideString;
1908 var
1909 L: Integer;
1910 P1, P2, Limit: PWideChar;
1911 begin
1912 L:=Length(S);
1913 P1:=Pointer(S);
1914 SetLength(Result, L);
1915 P2:=Pointer(Result);
1916 Limit:=P1 + L;
1917 while P1 < Limit do begin
1918 if P1^ <> C then begin
1919 P2^:=P1^;
1920 Inc(P2);
1921 end;
1922 Inc(P1);
1923 end; {while}
1924 SetLength(Result, P2 - Pointer(Result));
1925 end;
1926 {$ENDIF}
1927
RemoveCharsnull1928 function RemoveChars(const S: String; const CharsToRemove: TCharSet): String;
1929 var
1930 L: Integer;
1931 P1, P2, Limit: PChar;
1932 begin
1933 L:=Length(S);
1934 P1:={$IFDEF V_LONGSTRINGS}Pointer(S){$ELSE}@S[1]{$ENDIF};
1935 SetLength(Result, L);
1936 P2:={$IFDEF V_LONGSTRINGS}Pointer(Result){$ELSE}@Result[1]{$ENDIF};
1937 Limit:=P1 + L;
1938 while P1 < Limit do begin
1939 if not (P1^ in CharsToRemove) then begin
1940 P2^:=P1^;
1941 Inc(P2);
1942 end;
1943 Inc(P1);
1944 end; {while}
1945 SetLength(Result,
1946 {$IFNDEF V_FREEPASCAL}
1947 P2 - {$IFDEF V_LONGSTRINGS}Pointer(Result){$ELSE}@Result[1]{$ENDIF}
1948 {$ELSE}
1949 Cardinal(P2) - Cardinal(Pointer(Result))
1950 {$ENDIF}
1951 );
1952 end;
1953
1954 {$IFDEF V_WIDESTRINGS}
RemoveCharsWidenull1955 function RemoveCharsWide(const S: WideString; const CharsToRemove: TCharSet): WideString;
1956 var
1957 L: Integer;
1958 P1, P2, Limit: PWideChar;
1959 begin
1960 L:=Length(S);
1961 P1:=Pointer(S);
1962 SetLength(Result, L);
1963 P2:=Pointer(Result);
1964 Limit:=P1 + L;
1965 while P1 < Limit do begin
1966 if (P1^ >= #256) or not (PChar(P1)^ in CharsToRemove) then begin
1967 P2^:=P1^;
1968 Inc(P2);
1969 end;
1970 Inc(P1);
1971 end; {while}
1972 SetLength(Result, P2 - Pointer(Result));
1973 end;
1974 {$ENDIF}
1975
RemoveCommentnull1976 function RemoveComment(const S: String; CommentPrefix: Char): String;
1977 var
1978 I: Integer;
1979 C: Char;
1980 begin
1981 if CharPos(CommentPrefix, S, 1) = 0 then
1982 Result:=Trim(S)
1983 else begin
1984 C:=#0;
1985 for I:=1 to Length(S) do
1986 if S[I] = CommentPrefix then
1987 if C = #0 then begin
1988 Result:=Trim(Copy(S, 1, I - 1));
1989 Exit;
1990 end
1991 else
1992 else
1993 if S[I] in ['''', '"'] then
1994 if C = #0 then
1995 C:=S[I]
1996 else
1997 if C = S[I] then
1998 C:=#0;
1999 Result:=Trim(S);
2000 end;
2001 end;
2002
FStringToLiteralnull2003 function FStringToLiteral(const S: String; Quote: Char): String;
2004 var
2005 I, J, K, N: Integer;
2006 C: Char;
2007 begin
2008 I:=CharPos(Quote, S, 1);
2009 if I = 0 then
2010 Result:=Quote + S + Quote
2011 else begin
2012 Result:=Quote + Copy(S, 1, I) + Quote;
2013 N:=Length(S);
2014 SetLength(Result, N + 2 + NumOfChars(Quote, S));
2015 K:=I + 3;
2016 for J:=I + 1 to N do begin
2017 C:=S[J];
2018 if C = Quote then begin
2019 Result[K]:=C;
2020 Inc(K);
2021 end;
2022 Result[K]:=C;
2023 Inc(K);
2024 end;
2025 Result[K]:=Quote;
2026 end;
2027 end;
2028
StringToLiteralnull2029 function StringToLiteral(const S: String): String;
2030 begin
2031 Result:=FStringToLiteral(S, '''');
2032 end;
2033
StringToLiteral2null2034 function StringToLiteral2(const S: String): String;
2035 begin
2036 Result:=FStringToLiteral(S, '"');
2037 end;
2038
2039 {$IFDEF V_WIDESTRINGS}
FWideStringToLiteralnull2040 function FWideStringToLiteral(const S: WideString; Quote: WideChar): WideString;
2041 var
2042 I, J, K, N: Integer;
2043 C: WideChar;
2044 begin
2045 I:=WideCharPos(Quote, S, 1);
2046 if I = 0 then begin
2047 {$IFDEF V_D4}
2048 Result:=Quote + S + Quote
2049 {$ELSE}
2050 N:=Length(S);
2051 SetLength(Result, N + 2);
2052 Result[1]:=Quote;
2053 for I:=2 to N + 1 do
2054 Result[I]:=S[I - 1];
2055 Result[N + 2]:=Quote;
2056 {$ENDIF}
2057 end
2058 else begin
2059 N:=Length(S);
2060 {$IFDEF V_D4}
2061 Result:=Quote + Copy(S, 1, I) + Quote;
2062 {$ELSE}
2063 SetLength(Result, I + 2);
2064 Result[1]:=Quote;
2065 for J:=2 to I + 1 do
2066 Result[J]:=S[J - 1];
2067 Result[I + 2]:=Quote;
2068 {$ENDIF}
2069 SetLength(Result, N + 2 + NumOfWideChars(Quote, S));
2070 K:=I + 3;
2071 for J:=I + 1 to N do begin
2072 C:=S[J];
2073 if C = Quote then begin
2074 Result[K]:=C;
2075 Inc(K);
2076 end;
2077 Result[K]:=C;
2078 Inc(K);
2079 end;
2080 Result[K]:=Quote;
2081 end;
2082 end;
2083
WideStringToLiteralnull2084 function WideStringToLiteral(const S: WideString): WideString;
2085 begin
2086 Result:=FWideStringToLiteral(S, '''');
2087 end;
2088
WideStringToLiteral2null2089 function WideStringToLiteral2(const S: WideString): WideString;
2090 begin
2091 Result:=FWideStringToLiteral(S, '"');
2092 end;
2093 {$ENDIF}
2094
CheckTextnull2095 function CheckText(const S: String): Boolean;
2096 var
2097 I: Integer;
2098 begin
2099 Result:=False;
2100 if S <> '' then begin
2101 for I:=1 to Length(S) do
2102 if S[I] in [#0..' ', '"', '''', #127..#255] then
2103 Exit;
2104 Result:=True;
2105 end;
2106 end;
2107
2108 {$IFDEF V_WIDESTRINGS}
CheckWideTextnull2109 function CheckWideText(const W: WideString): Boolean;
2110 var
2111 I: Integer;
2112 C: WideChar;
2113 begin
2114 Result:=False;
2115 if W <> '' then begin
2116 for I:=1 to Length(W) do begin
2117 C:=W[I];
2118 if (C <= ' ') or (C = '"') or (C = '''') then
2119 Exit;
2120 end;
2121 Result:=True;
2122 end;
2123 end;
2124 {$ENDIF}
2125
TextToLiteralnull2126 function TextToLiteral(const S: String): String;
2127 begin
2128 if not CheckText(S) then
2129 Result:=StringToLiteral(S)
2130 else
2131 Result:=S;
2132 end;
2133
2134 {$IFDEF V_WIDESTRINGS}
WideTextToLiteralnull2135 function WideTextToLiteral(const S: WideString): WideString;
2136 begin
2137 if not CheckWideText(S) then
2138 Result:=WideStringToLiteral(S)
2139 else
2140 Result:=S;
2141 end;
2142 {$ENDIF}
2143
TextToLiteral2null2144 function TextToLiteral2(const S: String): String;
2145 begin
2146 if not CheckText(S) then
2147 Result:=StringToLiteral2(S)
2148 else
2149 Result:=S;
2150 end;
2151
2152 {$IFDEF V_WIDESTRINGS}
WideTextToLiteral2null2153 function WideTextToLiteral2(const S: WideString): WideString;
2154 begin
2155 if not CheckWideText(S) then
2156 Result:=WideStringToLiteral2(S)
2157 else
2158 Result:=S;
2159 end;
2160 {$ENDIF}
2161
2162 {$IFDEF NOWARN}{$WARNINGS OFF}{$ENDIF}
LiteralToStringnull2163 function LiteralToString(const S: String): String;
2164 var
2165 I, J, N: Integer;
2166 Quote, C: Char;
2167 begin
2168 N:=Length(S);
2169 if N >= 2 then begin
2170 if (S[1] = '''') and (S[N] = '''') then
2171 Quote:=''''
2172 else if (S[1] = '"') and (S[N] = '"') then
2173 Quote:='"'
2174 else begin
2175 Result:=S;
2176 Exit;
2177 end;
2178 Dec(N);
2179 SetLength(Result, N - 1);
2180 I:=2;
2181 J:=0;
2182 while I <= N do begin
2183 C:=S[I];
2184 Inc(J);
2185 Result[J]:=C;
2186 Inc(I);
2187 if (C = Quote) and ((I > N) or (S[I] = Quote)) then
2188 Inc(I);
2189 end;
2190 SetLength(Result, J);
2191 end
2192 else
2193 Result:=S;
2194 end;
2195
2196 {$IFDEF V_WIDESTRINGS}
LiteralToWideStringnull2197 function LiteralToWideString(const S: WideString): WideString;
2198 var
2199 I, J, N: Integer;
2200 Quote, C: WideChar;
2201 begin
2202 N:=Length(S);
2203 if N >= 2 then begin
2204 if (S[1] = '''') and (S[N] = '''') then
2205 Quote:=''''
2206 else if (S[1] = '"') and (S[N] = '"') then
2207 Quote:='"'
2208 else begin
2209 Result:=S;
2210 Exit;
2211 end;
2212 Dec(N);
2213 SetLength(Result, N - 1);
2214 I:=2;
2215 J:=0;
2216 while I <= N do begin
2217 C:=S[I];
2218 Inc(J);
2219 Result[J]:=C;
2220 Inc(I);
2221 if (C = Quote) and ((I > N) or (S[I] = Quote)) then
2222 Inc(I);
2223 end;
2224 SetLength(Result, J);
2225 end
2226 else
2227 Result:=S;
2228 end;
2229 {$ENDIF}
2230 {$IFDEF NOWARN}{$WARNINGS ON}{$ENDIF}
2231
GetValueByNamenull2232 function GetValueByName(const S, Name: String; var Value: String;
2233 CaseSensitive: Boolean; const QuoteChars: TCharSet): Boolean;
2234 var
2235 QuoteChar: Char;
2236 Valid: Boolean;
2237 ParamName: String;
2238 ReadState: (rsWaitName, rsName, rsWaitEqualSign, rsWaitValue, rsValue);
2239
2240 procedure StateReadName(C: Char);
2241 begin
2242 ReadState:=rsName;
2243 if C in QuoteChars then begin
2244 ReadState:=rsValue;
2245 QuoteChar:=C;
2246 Valid:=False;
2247 end
2248 else
2249 ParamName:=C;
2250 end;
2251
AnalyzeNamenull2252 function AnalyzeName: Boolean;
2253 begin
2254 if Valid then
2255 if CaseSensitive then
2256 Result:=CompareStr(ParamName, Name) = 0
2257 else
2258 Result:=CompareText(ParamName, Name) = 0
2259 else
2260 Result:=False;
2261 Valid:=True;
2262 end;
2263
2264 var
2265 C: Char;
2266 P, Limit: PChar;
2267 begin
2268 Result:=True;
2269 Valid:=True;
2270 {$IFDEF V_LONGSTRINGS}
2271 P:=PChar(S);
2272 {$ELSE}
2273 P:=@S[1];
2274 {$ENDIF}
2275 Limit:=P + Length(S);
2276 {$IFNDEF V_AUTOINITSTRINGS}
2277 ParamName:='';
2278 {$ENDIF}
2279 ReadState:=rsWaitName;
2280 while P < Limit do begin
2281 C:=P^;
2282 Case ReadState of
2283 rsWaitName:
2284 if C > ' ' then
2285 StateReadName(C);
2286 rsName:
2287 if C > ' ' then
2288 if C = '=' then
2289 ReadState:=rsWaitValue
2290 else
2291 if Valid then
2292 ParamName:=ParamName + C
2293 else
2294 else
2295 ReadState:=rsWaitEqualSign;
2296 rsWaitEqualSign:
2297 if C > ' ' then
2298 if C = '=' then
2299 ReadState:=rsWaitValue
2300 else begin
2301 if AnalyzeName then
2302 Exit;
2303 StateReadName(C);
2304 end;
2305 rsWaitValue:
2306 if C > ' ' then begin
2307 if C in QuoteChars then begin
2308 QuoteChar:=C;
2309 Value:='';
2310 end
2311 else begin
2312 QuoteChar:=#0;
2313 Value:=C;
2314 end;
2315 ReadState:=rsValue;
2316 end;
2317 rsValue: begin
2318 if QuoteChar <> #0 then
2319 if C = QuoteChar then begin
2320 ReadState:=rsWaitName;
2321 QuoteChar:=#0;
2322 end
2323 else
2324 else
2325 if C <= ' ' then
2326 ReadState:=rsWaitName;
2327 if ReadState = rsWaitName then
2328 if AnalyzeName then
2329 Exit
2330 else
2331 else
2332 if Valid then
2333 Value:=Value + C;
2334 end;
2335 End;
2336 Inc(P);
2337 end; {while}
2338 if (ReadState = rsValue) and AnalyzeName then
2339 Exit;
2340 Result:=False;
2341 end;
2342
2343 {$IFDEF V_WIDESTRINGS}{$IFDEF V_D4}{$IFNDEF V_D6}
2344 procedure ConvertErrorFmt(ResString: PResStringRec; const Args: array of const);
2345 begin
2346 raise EConvertError.CreateFmt(LoadResString(ResString), Args);
2347 end;
2348
2349 procedure FormatError(ErrorCode: Integer; Format: PChar; FmtLen: Cardinal);
2350 var
2351 ResStr: PResStringRec;
2352 Buffer: array[0..31] of Char;
2353 begin
2354 if FmtLen > 31 then
2355 FmtLen:=31;
2356 if StrByteType(Format, FmtLen-1) = mbLeadByte then
2357 Dec(FmtLen);
2358 StrMove(Buffer, Format, FmtLen);
2359 Buffer[FmtLen]:=#0;
2360 if ErrorCode = 0 then
2361 ResStr:=@SInvalidFormat
2362 else
2363 ResStr:=@SArgumentMissing;
2364 ConvertErrorFmt(ResStr, [PChar(@Buffer)]);
2365 end;
2366
2367 procedure WideFormatError(ErrorCode: Integer; Format: PWideChar; FmtLen: Cardinal);
2368 var
2369 WideFormat: WideString;
2370 FormatText: string;
2371 begin
2372 SetLength(WideFormat, FmtLen);
2373 SetString(WideFormat, Format, FmtLen);
2374 FormatText := WideFormat;
2375 FormatError(ErrorCode, PChar(FormatText), FmtLen);
2376 end;
2377
2378 {$IFDEF PACKAGE}
FWideFormatBufnull2379 function FWideFormatBuf(var Buffer; BufLen: Cardinal; const Format;
2380 FmtLen: Cardinal; CurrencyDecimals: Byte; const Args: array of const): Cardinal;
2381 {$ELSE}
WideFormatBufnull2382 function WideFormatBuf(var Buffer; BufLen: Cardinal; const Format;
2383 FmtLen: Cardinal; const Args: array of const): Cardinal;
2384 {$ENDIF}
2385 var
2386 ArgIndex, Width, Prec: Integer;
2387 BufferOrg, FormatOrg, FormatPtr: PWideChar;
2388 JustFlag: WideChar;
2389 StrBuf: array[0..64] of WideChar;
2390 TempWideStr: WideString;
2391 TempInt64 : Int64;
2392 SaveGOT: Integer;
2393 { in: eax <-> Buffer }
2394 { in: edx <-> BufLen }
2395 { in: ecx <-> Format }
2396
2397 asm
2398 PUSH EBX
2399 PUSH ESI
2400 PUSH EDI
2401 MOV EDI,EAX
2402 MOV ESI,ECX
2403 {$IFDEF PIC}
2404 CALL GetGOT
2405 {$ELSE}
2406 XOR EAX,EAX
2407 {$ENDIF}
2408 MOV SaveGOT,EAX
2409 MOV ECX,FmtLen
2410 LEA ECX,[ECX*2+ESI]
2411 MOV BufferOrg,EDI
2412 XOR EAX,EAX
2413 MOV ArgIndex,EAX
2414 MOV TempWideStr,EAX
2415
2416 @Loop:
2417 OR EDX,EDX
2418 JE @Done
2419
2420 @NextChar:
2421 CMP ESI,ECX
2422 JE @Done
2423 LODSW
2424 CMP AX,'%'
2425 JE @Format
2426
2427 @StoreChar:
2428 STOSW
2429 DEC EDX
2430 JNE @NextChar
2431
2432 @Done:
2433 MOV EAX,EDI
2434 SUB EAX,BufferOrg
2435 SHR EAX,1
2436 JMP @Exit
2437
2438 @Format:
2439 CMP ESI,ECX
2440 JE @Done
2441 LODSW
2442 CMP AX,'%'
2443 JE @StoreChar
2444 LEA EBX,[ESI-4]
2445 MOV FormatOrg,EBX
2446 @A0: MOV JustFlag,AX
2447 CMP AX,'-'
2448 JNE @A1
2449 CMP ESI,ECX
2450 JE @Done
2451 LODSW
2452 @A1: CALL @Specifier
2453 CMP AX,':'
2454 JNE @A2
2455 MOV ArgIndex,EBX
2456 CMP ESI,ECX
2457 JE @Done
2458 LODSW
2459 JMP @A0
2460
2461 @A2: MOV Width,EBX
2462 MOV EBX,-1
2463 CMP AX,'.'
2464 JNE @A3
2465 CMP ESI,ECX
2466 JE @Done
2467 LODSW
2468 CALL @Specifier
2469 @A3: MOV Prec,EBX
2470 MOV FormatPtr,ESI
2471 PUSH ECX
2472 PUSH EDX
2473
2474 CALL @Convert
2475
2476 POP EDX
2477 MOV EBX,Width
2478 SUB EBX,ECX //(* ECX <=> number of characters output *)
2479 JAE @A4 //(* jump -> output smaller than width *)
2480 XOR EBX,EBX
2481
2482 @A4: CMP JustFlag,'-'
2483 JNE @A6
2484 SUB EDX,ECX
2485 JAE @A5
2486 ADD ECX,EDX
2487 XOR EDX,EDX
2488
2489 @A5: REP MOVSW
2490
2491 @A6: XCHG EBX,ECX
2492 SUB EDX,ECX
2493 JAE @A7
2494 ADD ECX,EDX
2495 XOR EDX,EDX
2496 @A7: MOV AX,' '
2497 REP STOSW
2498 XCHG EBX,ECX
2499 SUB EDX,ECX
2500 JAE @A8
2501 ADD ECX,EDX
2502 XOR EDX,EDX
2503 @A8: REP MOVSW
2504 POP ECX
2505 MOV ESI,FormatPtr
2506 JMP @Loop
2507
2508 @Specifier:
2509 XOR EBX,EBX
2510 CMP AX,'*'
2511 JE @B3
2512 @B1: CMP AX,'0'
2513 JB @B5
2514 CMP AX,'9'
2515 JA @B5
2516 IMUL EBX,EBX,10
2517 SUB AX,'0'
2518 MOVZX EAX,AX
2519 ADD EBX,EAX
2520 CMP ESI,ECX
2521 JE @B2
2522 LODSW
2523 JMP @B1
2524 @B2: POP EAX
2525 JMP @Done
2526 @B3: MOV EAX,ArgIndex
2527 CMP EAX,Args.Integer[-4]
2528 JA @B4
2529 INC ArgIndex
2530 MOV EBX,Args
2531 CMP [EBX+EAX*8].Byte[4],vtInteger
2532 MOV EBX,[EBX+EAX*8]
2533 JE @B4
2534 XOR EBX,EBX
2535 @B4: CMP ESI,ECX
2536 JE @B2
2537 LODSW
2538 @B5: RET
2539
2540 @Convert:
2541 AND AL,0DFH
2542 MOV CL,AL
2543 MOV EAX,1
2544 MOV EBX,ArgIndex
2545 CMP EBX,Args.Integer[-4]
2546 JA @ErrorExit
2547 INC ArgIndex
2548 MOV ESI,Args
2549 LEA ESI,[ESI+EBX*8]
2550 MOV EAX,[ESI].Integer[0] // TVarRec.data
2551 MOVZX EDX,[ESI].Byte[4] // TVarRec.VType
2552 {$IFDEF PIC}
2553 MOV EBX, SaveGOT
2554 ADD EBX, offset @CvtVector
2555 MOV EBX, [EBX+EDX*4]
2556 ADD EBX, SaveGOT
2557 JMP EBX
2558 {$ELSE}
2559 JMP @CvtVector.Pointer[EDX*4]
2560 {$ENDIF}
2561
2562 @CvtVector:
2563 DD @CvtInteger // vtInteger
2564 DD @CvtBoolean // vtBoolean
2565 DD @CvtChar // vtChar
2566 DD @CvtExtended // vtExtended
2567 DD @CvtShortStr // vtString
2568 DD @CvtPointer // vtPointer
2569 DD @CvtPChar // vtPChar
2570 DD @CvtObject // vtObject
2571 DD @CvtClass // vtClass
2572 DD @CvtWideChar // vtWideChar
2573 DD @CvtPWideChar // vtPWideChar
2574 DD @CvtAnsiStr // vtAnsiString
2575 DD @CvtCurrency // vtCurrency
2576 DD @CvtVariant // vtVariant
2577 DD @CvtInterface // vtInterface
2578 DD @CvtWideString // vtWideString
2579 DD @CvtInt64 // vtInt64
2580
2581 @CvtBoolean:
2582 @CvtObject:
2583 @CvtClass:
2584 @CvtInterface:
2585 @CvtError:
2586 XOR EAX,EAX
2587
2588 @ErrorExit:
2589 CALL @ClearTmpWideStr
2590 MOV EDX,FormatOrg
2591 MOV ECX,FormatPtr
2592 SUB ECX,EDX
2593 SHR ECX,1
2594 MOV EBX, SaveGOT
2595 {$IFDEF PC_MAPPED_EXCEPTIONS}
2596 // Because of all the assembly code here, we can't call a routine
2597 // that throws an exception if it looks like we're still on the
2598 // stack. The static disassembler cannot give sufficient unwind
2599 // frame info to unwind the confusion that is generated from the
2600 // assembly code above. So before we throw the exception, we
2601 // go to some lengths to excise ourselves from the stack chain.
2602 // We were passed 12 bytes of parameters on the stack, and we have
2603 // to make sure that we get rid of those, too.
2604 MOV ESP, EBP // Ditch everthing to the frame
2605 MOV EBP, [ESP + 4] // Get the return addr
2606 MOV [ESP + 16], EBP // Move the ret addr up in the stack
2607 POP EBP // Ditch the rest of the frame
2608 ADD ESP, 12 // Ditch the space that was taken by params
2609 JMP WideFormatError // Off to FormatErr
2610 {$ELSE}
2611 CALL WideFormatError
2612 {$ENDIF}
2613 // The above call raises an exception and does not return
2614
2615 @CvtInt64:
2616 // CL <= format character
2617 // EAX <= address of int64
2618 // EBX <= TVarRec.VType
2619
2620 LEA EBX, TempInt64 // (input is array of const; save original)
2621 MOV EDX, [EAX]
2622 MOV [EBX], EDX
2623 MOV EDX, [EAX + 4]
2624 MOV [EBX + 4], EDX
2625
2626 // EBX <= address of TempInt64
2627
2628 CMP CL,'D'
2629 JE @DecI64
2630 CMP CL,'U'
2631 JE @DecI64_2
2632 CMP CL,'X'
2633 JNE @CvtError
2634
2635 @HexI64:
2636 MOV ECX,16 // hex divisor
2637 JMP @CvtI64
2638
2639 @DecI64:
2640 TEST DWORD PTR [EBX + 4], $80000000 // sign bit set?
2641 JE @DecI64_2 // no -> bypass '-' output
2642
2643 NEG DWORD PTR [EBX] // negate lo-order, then hi-order
2644 ADC DWORD PTR [EBX+4], 0
2645 NEG DWORD PTR [EBX+4]
2646
2647 CALL @DecI64_2
2648
2649 MOV AX,'-'
2650 INC ECX
2651 INC ECX
2652 DEC ESI
2653 DEC ESI
2654 MOV [ESI],AX
2655 RET
2656
2657 @DecI64_2: // unsigned int64 output
2658 MOV ECX,10 // decimal divisor
2659
2660 @CvtI64:
2661 LEA ESI,StrBuf[64]
2662
2663 @CvtI64_1:
2664 PUSH EBX
2665 PUSH ECX // save radix
2666 PUSH 0
2667 PUSH ECX // radix divisor (10 or 16 only)
2668 MOV EAX, [EBX]
2669 MOV EDX, [EBX + 4]
2670 MOV EBX, SaveGOT
2671 CALL System.@_llumod
2672 POP ECX // saved radix
2673 POP EBX
2674
2675 XCHG EAX, EDX // lo-value to EDX for character output
2676 ADD DX,'0'
2677 CMP DX,'0'+10
2678 JB @CvtI64_2
2679
2680 ADD DX,('A'-'0')-10
2681
2682 @CvtI64_2:
2683 DEC ESI
2684 DEC ESI
2685 MOV [ESI],DX
2686
2687 PUSH EBX
2688 PUSH ECX // save radix
2689 PUSH 0
2690 PUSH ECX // radix divisor (10 or 16 only)
2691 MOV EAX, [EBX] // value := value DIV radix
2692 MOV EDX, [EBX + 4]
2693 MOV EBX, SaveGOT
2694 CALL System.@_lludiv
2695 POP ECX // saved radix
2696 POP EBX
2697 MOV [EBX], EAX
2698 MOV [EBX + 4], EDX
2699 OR EAX,EDX // anything left to output?
2700 JNE @CvtI64_1 // no jump => EDX:EAX = 0
2701
2702 LEA ECX,StrBuf[64]
2703 SUB ECX,ESI
2704 SHR ECX,1
2705 MOV EDX,Prec
2706 CMP EDX,16
2707 JBE @CvtI64_3
2708 RET
2709
2710 @CvtI64_3:
2711 SUB EDX,ECX
2712 JBE @CvtI64_5
2713 ADD ECX,EDX
2714 MOV AX,'0'
2715
2716 @CvtI64_4:
2717 DEC ESI
2718 DEC ESI
2719 MOV [ESI],AX
2720 DEC EDX
2721 JNE @CvtI64_4
2722
2723 @CvtI64_5:
2724 RET
2725 ////////////////////////////////////////////////
2726
2727 @CvtInteger:
2728 CMP CL,'D'
2729 JE @C1
2730 CMP CL,'U'
2731 JE @C2
2732 CMP CL,'X'
2733 JNE @CvtError
2734 MOV ECX,16
2735 JMP @CvtLong
2736 @C1: OR EAX,EAX
2737 JNS @C2
2738 NEG EAX
2739 CALL @C2
2740 MOV AX,'-'
2741 INC ECX
2742 DEC ESI
2743 DEC ESI
2744 MOV [ESI],AX
2745 RET
2746 @C2: MOV ECX,10
2747
2748 @CvtLong:
2749 LEA ESI,StrBuf[32]
2750 @D1: XOR EDX,EDX
2751 DIV ECX
2752 ADD EDX,'0'
2753 CMP EDX,'0'+10
2754 JB @D2
2755 ADD EDX,('A'-'0')-10
2756 @D2: DEC ESI
2757 DEC ESI
2758 MOV [ESI],DX
2759 OR EAX,EAX
2760 JNE @D1
2761 LEA ECX,StrBuf[32]
2762 SUB ECX,ESI
2763 SHR ECX,1
2764 MOV EDX,Prec
2765 CMP EDX,16
2766 JBE @D3
2767 RET
2768 @D3: SUB EDX,ECX
2769 JBE @D5
2770 ADD ECX,EDX
2771 MOV AX,'0'
2772 @D4: DEC ESI
2773 DEC ESI
2774 MOV [ESI],AX
2775 DEC EDX
2776 JNE @D4
2777 @D5: RET
2778
2779 @CvtChar:
2780 CMP CL,'S'
2781 JNE @CvtError
2782 MOV EAX,ESI
2783 MOV ECX,1
2784 JMP @CvtAnsiThingLen
2785
2786 @CvtWideChar:
2787 CMP CL,'S'
2788 JNE @CvtError
2789 MOV ECX,1
2790 RET
2791
2792 @CvtVariant:
2793 CMP CL,'S'
2794 JNE @CvtError
2795 CMP [EAX].TVarData.VType,varNull
2796 JBE @CvtEmptyStr
2797 MOV EDX,EAX
2798 LEA EAX,TempWideStr
2799 PUSH EBX
2800 MOV EBX, SaveGOT
2801 CALL System.@VarToWStr
2802 POP EBX
2803 MOV ESI,TempWideStr
2804 JMP @CvtWideStrRef
2805
2806 @CvtEmptyStr:
2807 XOR ECX,ECX
2808 RET
2809
2810 @CvtShortStr:
2811 CMP CL,'S'
2812 JNE @CvtError
2813 MOVZX ECX,BYTE PTR [EAX]
2814 INC EAX
2815
2816 @CvtAnsiThingLen:
2817 MOV ESI,OFFSET System.@WStrFromPCharLen
2818 JMP @CvtAnsiThing
2819
2820 @CvtPChar:
2821 MOV ESI,OFFSET System.@WStrFromPChar
2822 JMP @CvtAnsiThingTest
2823
2824 @CvtAnsiStr:
2825 MOV ESI,OFFSET System.@WStrFromLStr
2826
2827 @CvtAnsiThingTest:
2828 CMP CL,'S'
2829 JNE @CvtError
2830
2831 @CvtAnsiThing:
2832 ADD ESI, SaveGOT
2833 MOV EDX,EAX
2834 LEA EAX,TempWideStr
2835 PUSH EBX
2836 MOV EBX, SaveGOT
2837 CALL ESI
2838 POP EBX
2839 MOV ESI,TempWideStr
2840 JMP @CvtWideStrRef
2841
2842 @CvtWideString:
2843 CMP CL,'S'
2844 JNE @CvtError
2845 MOV ESI,EAX
2846
2847 @CvtWideStrRef:
2848 OR ESI,ESI
2849 JE @CvtEmptyStr
2850 MOV ECX,[ESI-4]
2851 SHR ECX,1
2852
2853 @CvtWideStrLen:
2854 CMP ECX,Prec
2855 JA @E1
2856 RET
2857 @E1: MOV ECX,Prec
2858 RET
2859
2860 @CvtPWideChar:
2861 CMP CL,'S'
2862 JNE @CvtError
2863 MOV ESI,EAX
2864 PUSH EDI
2865 MOV EDI,EAX
2866 XOR EAX,EAX
2867 MOV ECX,Prec
2868 JECXZ @F1
2869 REPNE SCASW
2870 JNE @F1
2871 DEC EDI
2872 DEC EDI
2873 @F1: MOV ECX,EDI
2874 SUB ECX,ESI
2875 SHR ECX,1
2876 POP EDI
2877 RET
2878
2879 @CvtPointer:
2880 CMP CL,'P'
2881 JNE @CvtError
2882 MOV Prec,8
2883 MOV ECX,16
2884 JMP @CvtLong
2885
2886 @CvtCurrency:
2887 MOV BH,fvCurrency
2888 JMP @CvtFloat
2889
2890 @CvtExtended:
2891 MOV BH,fvExtended
2892
2893 @CvtFloat:
2894 MOV ESI,EAX
2895 MOV BL,ffGeneral
2896 CMP CL,'G'
2897 JE @G2
2898 MOV BL,ffExponent
2899 CMP CL,'E'
2900 JE @G2
2901 MOV BL,ffFixed
2902 CMP CL,'F'
2903 JE @G1
2904 MOV BL,ffNumber
2905 CMP CL,'N'
2906 JE @G1
2907 CMP CL,'M'
2908 JNE @CvtError
2909 MOV BL,ffCurrency
2910 @G1: MOV EAX,18
2911 MOV EDX,Prec
2912 CMP EDX,EAX
2913 JBE @G3
2914 MOV EDX,2
2915 CMP CL,'M'
2916 JNE @G3
2917 MOVZX EDX,CurrencyDecimals
2918 JMP @G3
2919 @G2: MOV EAX,Prec
2920 MOV EDX,3
2921 CMP EAX,18
2922 JBE @G3
2923 MOV EAX,15
2924 @G3: PUSH EBX
2925 PUSH EAX
2926 PUSH EDX
2927 LEA EAX,StrBuf
2928 MOV EDX,ESI
2929 MOVZX ECX,BH
2930 MOV EBX, SaveGOT
2931 CALL FloatToText
2932 MOV ECX,EAX
2933 LEA EAX,StrBuf
2934 JMP @CvtAnsiThingLen
2935
2936 @ClearTmpWideStr:
2937 PUSH EBX
2938 PUSH EAX
2939 LEA EAX,TempWideStr
2940 MOV EBX, SaveGOT
2941 CALL System.@WStrClr
2942 POP EAX
2943 POP EBX
2944 RET
2945
2946 @Exit:
2947 CALL @ClearTmpWideStr
2948 POP EDI
2949 POP ESI
2950 POP EBX
2951 end;
2952
2953 {$IFDEF PACKAGE}
WideFormatBufnull2954 function WideFormatBuf(var Buffer; BufLen: Cardinal; const Format;
2955 FmtLen: Cardinal; const Args: array of const): Cardinal;
2956 begin
2957 Result:=FWideFormatBuf(Buffer, BufLen, Format, FmtLen, CurrencyDecimals, Args);
2958 end;
2959 {$ENDIF}
2960
2961 procedure WideFmtStr(var Result: WideString; const Format: WideString;
2962 const Args: array of const);
2963 var
2964 Len, BufLen: Integer;
2965 Buffer: array[0..4095] of WideChar;
2966 begin
2967 BufLen := SizeOf(Buffer);
2968 if Length(Format) < (sizeof(Buffer) - (sizeof(Buffer) div 4)) then
2969 Len := WideFormatBuf(Buffer, sizeof(Buffer) - 1, Pointer(Format)^, Length(Format), Args)
2970 else
2971 begin
2972 BufLen := Length(Format);
2973 Len := BufLen;
2974 end;
2975 if Len >= BufLen - 1 then
2976 begin
2977 while Len >= BufLen - 1 do
2978 begin
2979 Inc(BufLen, BufLen);
2980 Result := ''; // prevent copying of existing data, for speed
2981 SetLength(Result, BufLen);
2982 Len := WideFormatBuf(Pointer(Result)^, BufLen - 1, Pointer(Format)^,
2983 Length(Format), Args);
2984 end;
2985 SetLength(Result, Len);
2986 end
2987 else
2988 SetString(Result, Buffer, Len);
2989 end;
2990
WideFormatnull2991 function WideFormat(const Format: WideString; const Args: array of const): WideString;
2992 begin
2993 WideFmtStr(Result, Format, Args);
2994 end;
2995 {$ENDIF}{$ENDIF}{$ENDIF}
2996
2997 {$IFDEF V_D4}
IntToStrSeparatednull2998 function IntToStrSeparated(Value: Int64): String;
2999 var
3000 I, C: Integer;
3001 S: String;
3002 begin
3003 S:=IntToStr(Value);
3004 Result:='';
3005 C:=0;
3006 for I:=Length(S) downto 1 do begin
3007 if C = 3 then begin
3008 Result:=ThousandSeparator + Result;
3009 C:=0;
3010 end;
3011 Result:=S[I] + Result;
3012 Inc(C);
3013 end;
3014 end;
3015 {$ENDIF}
3016
IntToRomannull3017 function IntToRoman(N: Integer): String;
3018 const
3019 T_s: array [0..5] of String = ('','M','MM','MMM','MMMM','MMMMM');
3020 S_s: array [0..9] of String = ('','C','CC','CCC','CD','D','DC','DCC','DCCC','CM');
3021 D_s: array [0..9] of String = ('','X','XX','XXX','XL','L','LX','LXX','LXXX','XC');
3022 E_s: array [0..9] of String = ('','I','II','III','IV','V','VI','VII','VIII','IX');
3023 var
3024 T, S, D: Integer;
3025 begin
3026 if (N >= 1) and (N <= 5000) then begin
3027 T:=0;
3028 while N >= 1000 do begin
3029 Dec(N, 1000);
3030 Inc(T);
3031 end;
3032 S:=0;
3033 if N >= 500 then begin
3034 Dec(N, 500);
3035 S:=5;
3036 end;
3037 while N >= 100 do begin
3038 Dec(N, 100);
3039 Inc(S);
3040 end;
3041 D:=0;
3042 if N >= 50 then begin
3043 Dec(N, 50);
3044 D:=5;
3045 end;
3046 while N >= 10 do begin
3047 Dec(N, 10);
3048 Inc(D);
3049 end;
3050 Result:=T_s[T] + S_s[S] + D_s[D] + E_s[N];
3051 end
3052 else
3053 Result:='';
3054 end;
3055
ValOctPCharnull3056 function ValOctPChar(P: PChar; L: Integer; var Value: Integer): Boolean;
3057 var
3058 N: Integer;
3059 begin
3060 Value:=0;
3061 if L = 0 then begin
3062 Result:=False;
3063 Exit;
3064 end;
3065 while L > 0 do begin
3066 N:=Ord(P^) - Ord('0');
3067 if (N < 0) or (N > 7) then begin
3068 Result:=False;
3069 Exit;
3070 end;
3071 Value:=Value * 8 + N;
3072 Inc(P);
3073 Dec(L);
3074 end;
3075 Result:=True;
3076 end;
3077
ValOctStrnull3078 function ValOctStr(const S: String; var Value: Integer): Boolean;
3079 begin
3080 Result:=ValOctPChar({$IFDEF V_LONGSTRINGS}Pointer(S){$ELSE}@S[1]{$ENDIF},
3081 Length(S), Value);
3082 end;
3083
OctToIntnull3084 function OctToInt(P: PChar; MaxLen: Integer; var Value: Integer): Boolean;
3085 var
3086 I, J: Integer;
3087 begin
3088 while (MaxLen > 0) and (P^ = ' ') do begin
3089 Dec(MaxLen);
3090 Inc(P);
3091 end; {while}
3092 if MaxLen <= 0 then begin
3093 Result:=False;
3094 Exit;
3095 end;
3096 I:=IndexOfValue8(P^, 0, MaxLen);
3097 if I < 0 then
3098 I:=MaxLen;
3099 J:=IndexOfValue8(P^, Ord(' '), MaxLen);
3100 if J < 0 then
3101 J:=MaxLen;
3102 if I > J then
3103 I:=J;
3104 Result:=ValOctPChar(P, I, Value);
3105 end;
3106
CmpStrFnull3107 function CmpStrF(const S1, S2: String; Flags: LongInt): Integer;
3108 begin
3109 {$IFDEF V_WIN}
3110 {$IFDEF V_LONGSTRINGS}
3111 if Flags = 0 then
3112 Result:=CompareStr(S1, S2)
3113 else
3114 Result:=CompareString(Flags and LocaleMask, Flags and FlagsMask, Pointer(S1),
3115 Length(S1), Pointer(S2), Length(S2)) - 2;
3116 {$ELSE}
3117 if Flags and LocaleMask <> 0 then
3118 if Flags and iCaseInsensitive <> 0 then
3119 Result:=AnsiCompareText(S1, S2)
3120 else
3121 Result:=AnsiCompareStr(S1, S2)
3122 else
3123 if Flags and iCaseInsensitive <> 0 then
3124 Result:=CompareText(S1, S2)
3125 else
3126 Result:=CompareStr(S1, S2)
3127 {$ENDIF}
3128 {$ELSE}
3129 if Flags and LocaleMask <> 0 then
3130 if Flags and iCaseInsensitive <> 0 then
3131 Result:=AnsiCompareText(S1, S2)
3132 else
3133 Result:=AnsiCompareStr(S1, S2)
3134 else
3135 if Flags and iCaseInsensitive <> 0 then
3136 Result:=CompareText(S1, S2)
3137 else
3138 Result:=CompareStr(S1, S2)
3139 {$ENDIF}
3140 end;
3141
3142 {$IFDEF V_WIDESTRINGS}
3143 {$IFNDEF USE_ASM}
WStrCmpnull3144 function WStrCmp(PLeft, PRight: PWideChar): Integer;
3145 begin
3146 Result:=CompareWide(WideString(PLeft), WideString(PRight));
3147 end;
3148
CompareWidenull3149 function CompareWide(const Left, Right: WideString): Integer;
3150 begin
3151 if Left < Right then
3152 Result:=-1
3153 else if Left > Right then
3154 Result:=1
3155 else Result:=0;
3156 end;
3157 {$ELSE}
WStrCmpnull3158 function WStrCmp(PLeft, PRight: PWideChar): Integer;
3159 asm // eax = PLeft; edx = PRight
3160 {$IFDEF V_FREEPASCAL}
3161 mov edx, PRight
3162 {$ENDIF}
3163 push esi
3164 xor ecx, ecx
3165 mov esi, PLeft
3166 xor eax, eax
3167 cmp esi, edx
3168 je @@Exit
3169 or esi, esi
3170 jz @@str1null
3171 or edx, edx
3172 jz @@str2null
3173 @@Loop: // unrolled to improve efficiency
3174 lodsw
3175 mov cx, [edx]
3176 sub eax, ecx
3177 jnz @@Exit
3178 add edx, 2
3179 or ecx, ecx
3180 jz @@Exit
3181 lodsw
3182 mov cx, [edx]
3183 sub eax, ecx
3184 jnz @@Exit
3185 add edx, 2
3186 or ecx, ecx
3187 jz @@Exit
3188 lodsw
3189 mov cx, [edx]
3190 sub eax, ecx
3191 jnz @@Exit
3192 add edx, 2
3193 or ecx, ecx
3194 jz @@Exit
3195 lodsw
3196 mov cx, [edx]
3197 sub eax, ecx
3198 jnz @@Exit
3199 add edx, 2
3200 or ecx, ecx
3201 jnz @@Loop
3202 @@Exit:
3203 pop esi
3204 ret
3205 @@str1null:
3206 cmp word ptr [edx], 0
3207 je @@Exit
3208 dec eax
3209 jmp @@Exit
3210 @@str2null:
3211 cmp word ptr [esi], 0
3212 je @@Exit
3213 inc eax
3214 jmp @@Exit
3215 end{$IFDEF V_FREEPASCAL} ['eax','ecx','edx']{$ENDIF};
3216
CompareWidenull3217 function CompareWide(const Left, Right: WideString): Integer;
3218 begin
3219 Result:=WStrCmp(PWideChar(Left), PWideChar(Right));
3220 end;
3221 {$ENDIF} {USE_ASM}
3222
CompareStrBufWidenull3223 function CompareStrBufWide(PW1, PW2: PWideChar; Count1, Count2: Integer): Integer;
3224 var
3225 I, L, Delta: Integer;
3226 begin
3227 L:=Count1;
3228 Delta:=Count1 - Count2;
3229 if Delta > 0 then L:=Count2;
3230 for I:=0 to L - 1 do begin
3231 Result:=Integer(PW1^) - Integer(PW2^);
3232 if Result <> 0 then Exit;
3233 Inc(PW1);
3234 Inc(PW2);
3235 end;
3236 Result:=Delta;
3237 end;
3238
CompareStrWidenull3239 function CompareStrWide(const W1, W2: WideString): Integer;
3240 begin
3241 Result:=CompareStrBufWide(PWideChar(W1), PWideChar(W2), Length(W1), Length(W2));
3242 end;
3243 {$ENDIF} {V_WIDESTRINGS}
3244
CompareStrBufnull3245 function CompareStrBuf(P1, P2: PChar; Count1, Count2: Integer): Integer;
3246 var
3247 I, L, Delta: Integer;
3248 begin
3249 L:=Count1;
3250 Delta:=Count1 - Count2;
3251 if Delta > 0 then
3252 L:=Count2;
3253 for I:=0 to L - 1 do begin
3254 Result:=Ord(P1^) - Ord(P2^);
3255 if Result <> 0 then
3256 Exit;
3257 Inc(P1);
3258 Inc(P2);
3259 end;
3260 Result:=Delta;
3261 end;
3262
CompareTextBufnull3263 function CompareTextBuf(P1, P2: PChar; Count1, Count2: Integer): Integer;
3264 var
3265 I, L, C1, C2, Delta: Integer;
3266 begin
3267 L:=Count1;
3268 Delta:=Count1 - Count2;
3269 if Delta > 0 then
3270 L:=Count2;
3271 for I:=0 to L - 1 do begin
3272 C1:=Ord(P1^);
3273 C2:=Ord(P2^);
3274 if (C1 >= Ord('A')) and (C1 <= Ord('Z')) then
3275 Inc(C1, Ord('a') - Ord('A'));
3276 if (C2 >= Ord('A')) and (C2 <= Ord('Z')) then
3277 Inc(C2, Ord('a') - Ord('A'));
3278 Result:=C1 - C2;
3279 if Result <> 0 then
3280 Exit;
3281 Inc(P1);
3282 Inc(P2);
3283 end;
3284 Result:=Delta;
3285 end;
3286
MemEqualStrnull3287 function MemEqualStr(const X; const S: String): Boolean;
3288 begin
3289 Result:=MemEqual(X, {$IFDEF V_LONGSTRINGS}Pointer(S)^{$ELSE}S[1]{$ENDIF}, Length(S));
3290 end;
3291
CompareVersionsnull3292 function CompareVersions(Ver1, Ver2: String; pError: PBoolean): Integer;
3293
GetPartnull3294 function GetPart(var Ver: String; var N: Integer): Boolean;
3295 var
3296 I, Code: Integer;
3297 S: String;
3298 begin
3299 N:=0;
3300 I:=CharPos('.', Ver, 1);
3301 if I > 0 then begin
3302 S:=Copy(Ver, 1, I - 1);
3303 Delete(Ver, 1, I);
3304 end
3305 else begin
3306 S:=Ver;
3307 Ver:='';
3308 end;
3309 if S <> '' then begin
3310 Val(S, N, Code);
3311 if (Code <> 0) or (N < 0) then begin
3312 Result:=False;
3313 Exit;
3314 end;
3315 end;
3316 Result:=True;
3317 end;
3318
3319 var
3320 N1, N2: Integer;
3321 Error: Boolean;
3322 begin
3323 Result:=0;
3324 Error:=False;
3325 repeat
3326 if not (GetPart(Ver1, N1) and GetPart(Ver2, N2)) then begin
3327 Error:=True;
3328 Break;
3329 end;
3330 Result:=N1 - N2;
3331 if Result <> 0 then
3332 Break;
3333 until (Ver1 = '') and (Ver2 = '');
3334 if pError <> nil then
3335 Boolean(pError^):=Error; { Boolean(...) is for Free Pascal }
3336 end;
3337
3338 end.
3339