1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
|
{ Program to test system unit setstring routines
Tested against Delphi 3 and (where possible)
against Borland Pascal v7.01
Copyright (c) 2002 Carl Eric Codere
}
{ second version compiled with $H+ }
program tsetstr;
{$R+}
{$Q+}
{$ifndef MACOS}
{$APPTYPE CONSOLE}
{$else}
{$APPTYPE TOOL}
{$endif}
{$H+}
{$ifdef fpc}
{$ifndef ver1_0}
{$define haswidestring}
{$endif}
{$else}
{$ifndef ver70}
{$define haswidestring}
{$endif}
{$endif}
{$ifdef fpc}
uses strings;
{$else}
uses sysutils;
{$endif}
const
HELLO_STRING = 'Hello my little world!';
PCHAR_NULL = nil;
PCHAR_EMPTY : pchar = #0;
PCHAR_NORMAL : pchar = HELLO_STRING;
var
arr: array[0..255] of byte;
str1 : shortstring;
str2 : ansistring;
{$ifdef haswidestring}
str3 : widestring;
{$endif}
procedure fail;
begin
WriteLn('Failed!');
Halt(1);
end;
procedure test_shortstring;
var
i: longint;
_failed : boolean;
begin
_failed := false;
write('Testing setstring() with shortstring...');
{ buffer : pchar with #0 character }
{ pchar = nil }
{ pchar = valid value }
str1:='';
setstring(str1, PCHAR_NULL, 0);
if str1 <> '' then
_failed := true;
str1:='';
setstring(str1,PCHAR_EMPTY,strlen(PCHAR_EMPTY));
if str1 <> '' then
_failed := true;
setstring(str1,PCHAR_NORMAL,strlen(PCHAR_NORMAL));
if str1 <> HELLO_STRING then
_failed := true;
{ len = 0, len = normal length, len > 255 }
str1:='';
setstring(str1, PCHAR_NORMAL, 0);
if str1 <> '' then
_failed := true;
str1:='';
fillchar(arr,sizeof(arr),'a');
setstring(str1,@arr[0],512);
if length(str1) <> 255 then
_failed := true;
for i := 1 to length(str1) do
if str1[i] <> 'a' then
_failed := true;
str1:='';
setstring(str1,PCHAR_NORMAL,strlen(PCHAR_NORMAL));
if str1 <> HELLO_STRING then
_failed := true;
if _failed then
fail;
writeln('Passed!');
end;
procedure test_ansistring;
var
_failed : boolean;
begin
_failed := false;
write('Testing setstring() with ansistring...');
{ buffer : pchar with #0 character }
{ pchar = nil }
{ pchar = valid value }
str2:='';
setstring(str2, PCHAR_NULL, 0);
if str2 <> '' then
_failed := true;
str2:='';
setstring(str2,PCHAR_EMPTY,strlen(PCHAR_EMPTY));
if str2 <> '' then
_failed := true;
setstring(str2,PCHAR_NORMAL,strlen(PCHAR_NORMAL));
if str2 <> HELLO_STRING then
_failed := true;
{ len = 0, len = normal length, len > 255 }
str2:='';
setstring(str2, PCHAR_NORMAL, 0);
if str2 <> '' then
_failed := true;
str2:='';
setstring(str2,PCHAR_NORMAL,strlen(PCHAR_NORMAL));
if str2 <> HELLO_STRING then
_failed := true;
if _failed then
fail;
writeln('Passed!');
end;
{$ifdef haswidestring}
procedure test_widestring;
var
_failed : boolean;
begin
_failed := false;
write('Testing setstring() with widestring...');
{ buffer : pchar with #0 character }
{ pchar = nil }
{ pchar = valid value }
str3:='';
setstring(str3, PCHAR_NULL, 0);
if str3 <> '' then
_failed := true;
str3:='';
setstring(str3,PCHAR_EMPTY,strlen(PCHAR_EMPTY));
if str3 <> '' then
_failed := true;
setstring(str3,PCHAR_NORMAL,strlen(PCHAR_NORMAL));
if str3 <> HELLO_STRING then
_failed := true;
{ len = 0, len = normal length, len > 255 }
str3:='';
setstring(str3, PCHAR_NORMAL, 0);
if str3 <> '' then
_failed := true;
str3:='';
setstring(str3,PCHAR_NORMAL,strlen(PCHAR_NORMAL));
if str3 <> HELLO_STRING then
_failed := true;
if _failed then
fail;
writeln('Passed!');
end;
{$endif}
Begin
test_shortstring;
test_ansistring;
{$ifdef haswidestring}
test_widestring;
{$endif}
end.
|
