1 {
2 This file is part of the Free Pascal run time library.
3
4 A file in Amiga system run time library.
5 Copyright (c) 2002-2003 by Nils Sjoholm
6 member of the Amiga RTL development team.
7
8 See the file COPYING.FPC, included in this distribution,
9 for details about the copyright.
10
11 This program is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
14
15 **********************************************************************}
16
17 unit pcq;
18
19 {
20
21 A unit to help port program from pcq pascal.
22
23 These are some of the common C pchar functions.
24
25 Changed a few of the functions.
26
27 ToUpper,
28 ToLower,
29 strnieq,
30 strieq,
31 strnieq,
32 stricmp
33 and strnicmp
34
35 They all use the utility.library for the checking or
36 the conversion. The utility.library is opened by all
37 programs as of version 1.3 of PCQ, so you don't need
38 to do that.
39
40 THIS IS CHANGED!
41 Looks like the strcompare functions in utility and locale
42 is buggy so I have redone this functions to use an
43 internal strcompare instead.
44
45 Added the define use_amiga_smartlink.
46 13 Jan 2003.
47
48 Changed integer > smallint.
49 10 Feb 2003.
50
51 Nils Sjoholm < nils.sjoholm@mailbox.swipnet.se
52
53 }
54
55 interface
56
57 uses exec,strings;
58
CheckBreaknull59 function CheckBreak: boolean;
60
isuppernull61 Function isupper(c : Char) : Boolean;
62 {
63 Returns True if the character is in A..Z
64 }
65
islowernull66 Function islower(c : Char) : Boolean;
67 {
68 Returns True if the character is in a..z
69 }
70
isalphanull71 Function isalpha(c : Char) : Boolean;
72 {
73 Returns True if the character is in A..Z or a..z
74 }
75
isdigitnull76 Function isdigit(c : Char) : Boolean;
77 {
78 Returns True if the character is in 0..9
79 }
80
isalnumnull81 Function isalnum(c : Char) : Boolean;
82 {
83 Returns True if isalpha or isdigit is true
84 }
85
isspacenull86 Function isspace(c : Char) : Boolean;
87 {
88 Returns true if the character is "white space", like a space,
89 form feed, line feed, carraige return, tab, whatever.
90 }
91
touppernull92 Function toupper(c : Char) : Char;
93 {
94 If the character is in a..z, the function returns the capital.
95 Otherwise it returns c. Not true, this function use the utility.library
96 to make the conversion.
97 }
98
tolowernull99 Function tolower(c : Char) : Char;
100 {
101 If c is in A..Z, the function returns the lower case letter.
102 Otherwise it returns c. Not true this function use the utility.library
103 to make the conversion.
104 }
105
lowercasenull106 function lowercase(c : char) : char;
107 {
108 If the character is in a..z, the function returns the capital.
109 Otherwise it returns c. Not true, this function use the utility.library
110 to make the conversion.
111 }
112
lowercasenull113 function lowercase(c : pchar): pchar;
114 {
115 Will turn the pchar till lowercase.
116 }
117
uppercasenull118 function uppercase(c : char): char;
119 {
120 If the character is in a..z, the function returns the capital.
121 Otherwise it returns c. Not true, this function use the utility.library
122 to make the conversion.
123 }
124
uppercasenull125 function uppercase(c: pchar): pchar;
126 {
127 Will turn the pchar till capital letters.
128 }
129
streqnull130 Function streq(s1, s2 : pchar) : Boolean;
131 {
132 Returns True if s1 and s2 are the same.
133 }
134
strneqnull135 Function strneq(s1, s2 : pchar; n : longint) : Boolean;
136 {
137 Returns True if the first n characters of s1 and s2 are identical.
138 }
139
strieqnull140 Function strieq(s1, s2 : pchar) : Boolean;
141 {
142 The same as streq(), but is case insensitive.
143 }
144
strnieqnull145 Function strnieq(s1, s2 : pchar; n : longint) : Boolean;
146 {
147 The same as strneq(), but case insensitive.
148 }
149
strcmpnull150 Function strcmp(s1, s2 : pchar) : longint;
151 {
152 Returns an longint < 0 if s1 < s2, zero if they are equal, and > 0
153 if s1 > s2.
154 }
155
stricmpnull156 Function stricmp(s1, s2 : pchar) : longint;
157 {
158 The same as strcmp, but not case sensitive
159 }
160
strncmpnull161 Function strncmp(s1, s2 : pchar; n : longint) : longint;
162 {
163 Same as strcmp(), but only considers the first n characters.
164 }
165
strnicmpnull166 Function strnicmp(s1, s2 : pchar; n : longint) : longint;
167 {
168 Same as strncmp, but not case sensitive
169 }
170
171 Procedure strcpy(s1, s2 : pchar);
172 {
173 Copies s2 into s1, appending a trailing zero. This is the same
174 as C, but opposite from 1.0.
175 }
176 Procedure strncpy(s1, s2 : pchar; n : smallint);
177 {
178 Copies s2 into s1, with a maximum of n characters. Appends a
179 trailing zero.
180 }
181
182 Procedure strncat(s1, s2 : pchar; n : smallint);
183 {
184 Appends at most n characters from s2 onto s1.
185 }
186
strdupnull187 Function strdup(s : pchar) : pchar;
188 {
189 This allocates a copy of the pchar 's', and returns a ptr
190 }
191
strposnull192 Function strpos(s1 : pchar; c : Char) : longint;
193 {
194 Return the position, starting at zero, of the first (leftmost)
195 occurance of c in s1. If there is no c, it returns -1.
196 }
197
strrposnull198 Function strrpos(s1 : pchar; c : Char) : longint;
199 {
200 Returns the longint position of the right-most occurance of c in s1.
201 If c is not in s1, it returns -1.
202 }
203
AllocStringnull204 Function AllocString(l : longint) : pchar;
205 {
206 Allocates l bytes, and returns a pointer to the allocated memory.
207 This memory is allocated through the new() function, so it will be returned
208 to the system at the end of your program. Note that the proper amount of RAM
209 to allocate is strlen(s) + 1.
210 }
211
212 Procedure FreeString(s : pchar);
213 {
214 This returns memory allocated by AllocString to the system. Since
215 the Amiga is a multitasking computer, you should always return memory you
216 don't need to the system.
217 }
218
219 implementation
220
221 const
222 SIGBREAKF_CTRL_C = $1000;
223
CheckBreaknull224 function CheckBreak: boolean;
225 begin
226 { check for Ctrl-C break by user }
227 if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then Begin
228 SetSignal(0,SIGBREAKF_CTRL_C);
229 CheckBreak := true;
230 end else CheckBreak := false;
231 end;
232
isuppernull233 Function isupper(c : Char) : Boolean;
234 begin
235 if ((ord(c) >= 192) and (ord(c) <= 223)) or ((c >= 'A') and (c <= 'Z'))
236 then isupper := true
237 else isupper := false;
238 end;
239
islowernull240 Function islower(c : Char) : Boolean;
241 begin
242 if ((ord(c) >= 224) and (ord(c) <= 254)) or ((c >= 'a') and (c <= 'z'))
243 then islower := true
244 else islower := false;
245 end;
246
isalphanull247 Function isalpha(c : Char) : Boolean;
248 begin
249 if ((ord(c) >= 192) and (ord(c) <= 223)) or ((c >= 'A') and (c <= 'Z'))
250 or ((ord(c) >= 224) and (ord(c) <= 254)) or ((c >= 'a') and (c <= 'z'))
251 then isalpha := true
252 else isalpha := false;
253 end;
254
isdigitnull255 Function isdigit(c : Char) : Boolean;
256 begin
257 if c in ['0'..'9'] then isdigit := true
258 else isdigit := false;
259 end;
260
isalnumnull261 Function isalnum(c : Char) : Boolean;
262 begin
263 if isalpha(c) or isdigit(c) then isalnum := true
264 else isalnum := false;
265 end;
266
isspacenull267 Function isspace(c : Char) : Boolean;
268 begin
269 if c in [#9..#13,#32] then isspace := true
270 else isspace := false;
271 end;
272
touppernull273 Function toupper(c : Char) : Char;
274 begin
275 if ((ord(c) >= 224) and (ord(c) <= 254)) or ((c >= 'a') and (c <= 'z'))
276 then c := char(ord(c)-32);
277 toupper := c;
278 end;
279
tolowernull280 Function tolower(c : Char) : Char;
281 begin
282 if ((ord(c) >= 192) and (ord(c) <= 223)) or ((c >= 'A') and (c <= 'Z'))
283 then c := char(ord(c)+32);
284 tolower := c;
285 end;
286
lowercasenull287 function lowercase(c : char) : char;
288 begin
289 lowercase := tolower(c);
290 end;
291
lowercasenull292 function lowercase(c : pchar): pchar;
293 var
294 i : longint;
295 begin
296 i := 0;
297 while c[i] <> #0 do begin
298 c[i] := tolower(c[i]);
299 i := succ(i);
300 end;
301 lowercase := c;
302 end;
303
uppercasenull304 function uppercase(c : char): char;
305 begin
306 uppercase := toupper(c);
307 end;
308
uppercasenull309 function uppercase(c: pchar): pchar;
310 var
311 i : longint;
312 begin
313 i := 0;
314 while c[i] <> #0 do begin
315 c[i] := toupper(c[i]);
316 i := succ(i);
317 end;
318 uppercase := c;
319 end;
320
streqnull321 Function streq(s1, s2 : pchar) : Boolean;
322 begin
323 streq := (strcomp(s1,s2) = 0);
324 end;
325
strneqnull326 Function strneq(s1, s2 : pchar; n : longint) : Boolean;
327 begin
328 strneq := (strlcomp(s1,s2,n) = 0);
329 end;
330
strieqnull331 Function strieq(s1, s2 : pchar) : Boolean;
332 begin
333 s1 := uppercase(s1);
334 s2 := uppercase(s2);
335 strieq := (strcomp(s1,s2)=0);
336 end;
337
strnieqnull338 Function strnieq(s1, s2 : pchar; n : longint) : Boolean;
339 begin
340 s1 := uppercase(s1);
341 s2 := uppercase(s2);
342 strnieq := (strlcomp(s1,s2,n)=0);
343 end;
344
strcmpnull345 Function strcmp(s1, s2 : pchar) : longint;
346 begin
347 strcmp := strcomp(s1,s2);
348 end;
349
stricmpnull350 Function stricmp(s1, s2 : pchar) : longint;
351 begin
352 s1 := uppercase(s1);
353 s2 := uppercase(s2);
354 stricmp := strcomp(s1,s2);
355 end;
356
strncmpnull357 Function strncmp(s1, s2 : pchar; n : longint) : longint;
358 begin
359 strncmp := strlcomp(s1,s2,n);
360 end;
361
strnicmpnull362 Function strnicmp(s1, s2 : pchar; n : longint) : longint;
363 begin
364 s1 := uppercase(s1);
365 s2 := uppercase(s2);
366 strnicmp := strlcomp(s1,s2,n);
367 end;
368
369 Procedure strcpy(s1, s2 : pchar);
370 begin
371 strcopy(s1,s2)
372 end;
373
374 Procedure strncpy(s1, s2 : pchar; n : smallint);
375 begin
376 strlcopy(s1,s2,n);
377 end;
378
379 Procedure strncat(s1, s2 : pchar; n : smallint);
380 begin
381 strlcat(s1,s2,n);
382 end;
383
strdupnull384 Function strdup(s : pchar) : pchar;
385 begin
386 strdup := StrNew(s);
387 end;
388
strposnull389 Function strpos(s1 : pchar; c : Char) : longint;
390 Var
391 count: Longint;
392 Begin
393
394 count := 0;
395 { As in Borland Pascal , if looking for NULL return null }
396 if c = #0 then
397 begin
398 strpos := -1;
399 exit;
400 end;
401 { Find first matching character of Ch in Str }
402 while S1[count] <> #0 do
403 begin
404 if C = S1[count] then
405 begin
406 strpos := count;
407 exit;
408 end;
409 Inc(count);
410 end;
411 { nothing found. }
412 strpos := -1;
413 end;
414
415
strrposnull416 Function strrpos(s1 : pchar; c : Char) : longint;
417 Var
418 count: Longint;
419 index: Longint;
420 Begin
421 count := Strlen(S1);
422 { As in Borland Pascal , if looking for NULL return null }
423 if c = #0 then
424 begin
425 strrpos := -1;
426 exit;
427 end;
428 Dec(count);
429 for index := count downto 0 do
430 begin
431 if C = S1[index] then
432 begin
433 strrpos := index;
434 exit;
435 end;
436 end;
437 { nothing found. }
438 strrpos := -1;
439 end;
440
441
AllocStringnull442 Function AllocString(l : longint) : pchar;
443 begin
444 AllocString := StrAlloc(l);
445 end;
446
447 Procedure FreeString(s : pchar);
448 begin
449 StrDispose(s);
450 end;
451
452 end.
453