1 {*******************************************************}
2 { }
3 { Add FastReport String Lbrary }
4 { }
5 { Copyright (c) 1995, 1996 AO ROSNO }
6 { Copyright (c) 1997, 1998 Master-Bank }
7 { }
8 { Copyright (c) 2001 by Stalker SoftWare }
9 { }
10 {*******************************************************}
11
12 unit frFuncStr;
13
14 interface
15
16
17 {$mode objfpc}
18
19 {$B-} {- Complete Boolean Evaluation }
20 {$R-} {- Range-Checking }
21 {$V-} {- Var-String Checking }
22 {$T-} {- Typed @ operator }
23 {$X+} {- Extended syntax }
24 {$P+} {- Open string params }
25 {$J+} {- Writeable structured consts }
26 {$H+} {- Use long strings by default }
27
28 {$DEFINE HASVARIANT}
29 {.$I LR_Vers.inc}
30
31 uses
32 SysUtils;
33
34 type
35 TfrCharSet = set of Char;
36
37 // RxLib
frWordPositionnull38 function frWordPosition(const N: Integer; const S: string; const WordDelims: TfrCharSet): Integer;
frExtractWordnull39 function frExtractWord(N: Integer; const S: string; const WordDelims: TfrCharSet): string;
frWordCountnull40 function frWordCount(const S: string; const WordDelims: TfrCharSet): Integer;
frIsWordPresentnull41 function frIsWordPresent(const W, S: string; const WordDelims: TfrCharSet): Boolean;
frNPosnull42 function frNPos(const C: string; S: string; N: Integer): Integer;
frReplaceStrnull43 function frReplaceStr(const S, Srch, Replace: string): string;
44
45 // StLib
frReplicatenull46 function frReplicate(cStr: String; nLen :Integer) :String;
frPadRightnull47 function frPadRight(cStr: String; nLen: Integer; cChar :String) :String;
frPadLeftnull48 function frPadLeft(cStr: String; nLen: Integer; cChar :String) :String;
frPadCenternull49 function frPadCenter( cStr: String; nWidth: Integer; cChar: String): String;
frEndPosnull50 function frEndPos(cStr, cSubStr: String) :Integer;
frCompareStrnull51 function frCompareStr(cStr1, cStr2: String) :Integer;
52
frLeftCopynull53 function frLeftCopy(cStr: String; nNum: Integer): String;
frRightCopynull54 function frRightCopy(cStr: String; nNum: Integer): String;
55
56 // Delphi
frDeletenull57 function frDelete(cStr: String; nIndex, nCount:Integer) :String;
frInsertnull58 function frInsert(cStr1, cStr2: String; nIndex:Integer) :String;
59
60 implementation
61 uses LazUTF8;
62
63 {--------------------------------------------------------------------}
64 { Return position first character N words in string S, use }
65 { const WordDelims (type TCharSet) as delimiter between words }
66 {--------------------------------------------------------------------}
frWordPositionnull67 function frWordPosition(const N: Integer; const S: string; const WordDelims: TfrCharSet): Integer;
68 var
69 Count, I: Integer;
70
71 begin
72
73 Count := 0;
74 I := 1;
75 Result := 0;
76 while (I <= Length(S)) and (Count <> N) do begin
77 { skip over delimiters }
78 while (I <= Length(S)) and (S[I] in WordDelims) do Inc(I);
79 { if we're not beyond end of S, we're at the start of a word }
80 if I <= Length(S) then Inc(Count);
81 { if not finished, find the end of the current word }
82 if Count <> N then
83 while (I <= Length(S)) and not (S[I] in WordDelims) do Inc(I)
84 else Result := I;
85 end; { while }
86
87 end; { frWordPosition }
88
89 {--------------------------------------------------------------------}
90 { Extract N word from string S, use WordDelims as }
91 { delimiter between words }
92 {--------------------------------------------------------------------}
frExtractWordnull93 function frExtractWord(N: Integer; const S: string; const WordDelims: TfrCharSet): string;
94 var
95 I: Integer;
96 Len: Integer;
97
98 begin
99
100 Len := 0;
101 I := frWordPosition(N, S, WordDelims);
102 if I <> 0 then
103 { find the end of the current word }
104 while (I <= Length(S)) and not(S[I] in WordDelims) do begin
105 { add the I'th character to result }
106 Inc(Len);
107 SetLength(Result, Len);
108 Result[Len] := S[I];
109 Inc(I);
110 end; { while }
111 SetLength(Result, Len);
112
113 end; { frExtractWord }
114
115 {--------------------------------------------------------------------}
116 { Count words in string S, use WordDelims as delimiter }
117 { between words }
118 {--------------------------------------------------------------------}
frWordCountnull119 function frWordCount(const S: string; const WordDelims: TfrCharSet): Integer;
120 var
121 SLen, I: Cardinal;
122
123 begin
124
125 Result := 0;
126 I := 1;
127 SLen := Length(S);
128 while I <= SLen do begin
129 while (I <= SLen) and (S[I] in WordDelims) do Inc(I);
130 if I <= SLen then Inc(Result);
131 while (I <= SLen) and not(S[I] in WordDelims) do Inc(I);
132 end; { while }
133
134 end; { frWordCount }
135
136 {--------------------------------------------------------------------}
137 { Check existing word W in string S, use }
138 { WordDelims as possible delimiters between words }
139 {--------------------------------------------------------------------}
frIsWordPresentnull140 function frIsWordPresent(const W, S: string; const WordDelims: TfrCharSet): Boolean;
141 var
142 Count, I: Integer;
143
144 begin
145
146 Result := False;
147 Count := frWordCount(S, WordDelims);
148 for I := 1 to Count do
149 if frExtractWord(I, S, WordDelims) = W then begin
150 Result := True;
151 Exit;
152 end; { if }
153
154 end; { frIsWordPresent }
155
156 {--------------------------------------------------------------------}
157 { Find position N substring C in string S }
158 {--------------------------------------------------------------------}
frNPosnull159 function frNPos(const C: string; S: string; N: Integer): Integer;
160 var
161 I, P, K: Integer;
162
163 begin
164
165 Result := 0;
166 K := 0;
167 for I := 1 to N do begin
168 P := Pos(C, S);
169 Inc(K, P);
170 if (I = N) and (P > 0) then begin
171 Result := K;
172 Exit;
173 end; { if }
174 if P > 0 then Delete(S, 1, P)
175 else Exit;
176 end; { for }
177
178 end; { frNPos }
179
180 {--------------------------------------------------------------------}
181 { Function exchange in string S all substrings Srch on }
182 { other substring, delivered as Replace. }
183 {--------------------------------------------------------------------}
frReplaceStrnull184 function frReplaceStr(const S, Srch, Replace: string): string;
185 var
186 I: Integer;
187 Source: string;
188
189 begin
190
191 Source := S;
192 Result := '';
193 repeat
194 I := Pos(Srch, Source);
195 if I > 0 then begin
196 Result := Result + UTF8Copy(Source, 1, I - 1) + Replace;
197 Source := UTF8Copy(Source, I + UTF8Length(Srch), MaxInt);
198 end
199 else Result := Result + Source;
200 until I <= 0;
201
202 end; { frReplaceStr }
203
204 {--------------------------------------------------------------------}
205 { Return nLen chars as cStr }
206 {--------------------------------------------------------------------}
frReplicatenull207 function frReplicate(cStr: String; nLen :Integer) :String;
208 var
209 nCou :Integer;
210
211 begin
212
213 Result := '';
214 for nCou := 1 to nLen do
215 Result := Result + cStr;
216
217 end; { Replicate }
218
219 {--------------------------------------------------------------------}
220 { Return string filled chars cChar from left to nLen }
221 {--------------------------------------------------------------------}
frPadLeftnull222 function frPadLeft(cStr: String; nLen: Integer; cChar :String) :String;
223 var
224 S :String;
225
226 begin
227
228 S := Trim(cStr);
229 Result := frReplicate(cChar, nLen-Length(S))+S;
230
231 end ; { frPadLeft }
232
233 {--------------------------------------------------------------------}
234 { Return string filled chars cChar from right to nLen }
235 {--------------------------------------------------------------------}
frPadRightnull236 function frPadRight(cStr: String; nLen: Integer; cChar :String) :String ;
237 var
238 S :String;
239
240 begin
241
242 S := Trim(cStr);
243 Result := S+frReplicate(cChar, nLen-Length(S));
244
245 end; { frPadRight }
246
247 {--------------------------------------------------------------------}
248 { Return centered string filled chars cChar with both side }
249 {--------------------------------------------------------------------}
frPadCenternull250 function frPadCenter( cStr: String; nWidth: Integer; cChar: String): String;
251 var
252 nPerSide :Integer;
253 cResult :String;
254
255 begin
256
257 nPerSide := (nWidth - Length(cStr)) div 2;
258 cResult := frPadLeft(cStr, (Length(cStr) + nPerSide), cChar);
259 Result := frPadRight(cResult, nWidth, cChar);
260
261 end; { frPadCenter }
262
263 {----------------------------------------------------------------}
264 { Find in string substring from end }
265 { Return position substing if found, else return 0 }
266 {----------------------------------------------------------------}
frEndPosnull267 function frEndPos(cStr, cSubStr: String) :Integer;
268 var
269 nCou :Integer;
270 nLenSS :Integer;
271 nLenS :Integer;
272
273 begin
274
275 nLenSS := Length(cSubStr);
276 nLenS := Length(cStr);
277 Result := 0 ;
278
279 if nLenSS > nLenS then Exit;
280
281 for nCou := nLenS downto 1 do
282 if UTF8Copy( cStr, nCou, nLenSS ) = cSubStr then
283 begin
284 Result := nCou;
285 Exit;
286 end; { if }
287
288 end; { frEndPos }
289
290 {--------------------------------------------------------------------}
291 { Return substring from first char to nNum }
292 {--------------------------------------------------------------------}
frLeftCopynull293 function frLeftCopy( cStr: String; nNum: Integer ): String;
294 begin
295 Result := UTF8Copy( cStr, 1, nNum );
296 end; { frLeftCopy }
297
298 {--------------------------------------------------------------------}
299 { Return substring from last char to position nNum }
300 {--------------------------------------------------------------------}
frRightCopynull301 function frRightCopy( cStr: String; nNum: Integer ): String;
302 begin
303 Result := '';
304 if nNum > Length( cStr ) then Exit;
305 Result := UTF8Copy( cStr, (UTF8Length(cStr) - nNum + 1), UTF8Length(cStr) );
306 end; { frRightCopy }
307
308 {--------------------------------------------------------------------}
309 { Delete nCount chars in string cStr from position nIndex }
310 {--------------------------------------------------------------------}
frDeletenull311 function frDelete(cStr: String; nIndex, nCount:Integer) :String;
312 begin
313 UTF8Delete(cStr, nIndex, nCount);
314 Result := cStr;
315 end; { frDelete }
316
317 {--------------------------------------------------------------------}
318 { Insert string cStr2 into string cStr1, from position nIndex }
319 {--------------------------------------------------------------------}
frInsertnull320 function frInsert(cStr1, cStr2: String; nIndex:Integer) :String;
321 begin
322 UTF8Insert(cStr1, cStr2, nIndex);
323 Result := cStr2;
324 end; { frDelete }
325
326 {----------------------------------------------------------------}
327 { Compare cStr1 and cStr2 and return number of the position }
328 { difference strings }
329 {----------------------------------------------------------------}
frCompareStrnull330 function frCompareStr(cStr1, cStr2: String) :Integer;
331 var
332 nLenMax :Integer;
333 nCou :Integer;
334
335 begin
336
337 Result := 0;
338
339 if Length( cStr1 ) > Length( cStr2 ) then
340 nLenMax := Length( cStr1 )
341 else
342 nLenMax := Length( cStr2 );
343
344 for nCou := 1 to nLenMax do
345 if UTF8Copy( cStr1, nCou, 1) <> UTF8Copy( cStr2, nCou, 1) then
346 begin
347 Result := nCou;
348 Exit;
349 end; { if }
350
351 end; { frCompareStr }
352
353 end.
354