1 unit utils;
2
3 {
4 }
5
6
7 interface
8
9
10 {$ifdef __GPC__}
11 {$x+}
12 uses gpcstrings,memman,gpcsmapi,erweiter;
13 {$endif}
14
15 {$ifdef fpc}
16 {$ifdef linux}
17 uses strings,dos,memman,erweiter,smapi;
18 {$define havedosunit}
19 {$endif}
20 {$endif}
21
22
23 {$ifdef ver70}
24 Sorry. Borland Pascal is not supported.
25 {$endif}
26
27
transstringnull28 function transstring(s:string):string;
29 procedure writelnspe(p:pchar);
string2addrnull30 function string2addr(s:String;var a:netaddr):boolean;
31 procedure word2timedate(time:word;date:word;var h,min,s:word; var d,mon,y:word);
showdatetimenull32 function showdatetime(date:word;time:word):string;
showdatenull33 function showdate(date:word):string;
showtimenull34 function showtime(time:word):string;
35 procedure datetime2ftsdate(var date,time:word;var fts:array of char);
showaddrnull36 function showaddr(a:netaddr):string;
longint2hexnull37 function longint2hex(l:longint):string;
msgidnull38 function msgid:longint;
array2stringnull39 function array2string(p:pchar;max:word):string;
40 procedure getfulladdr(var p:pchar;var size:longint;var o:netaddr;var d:netaddr);
41
42 implementation
43 const
44 RCSID: PChar = '$Id$';
45 lastmsgid:longint=0;
string2addrspenull46 function string2addrspe(s:String;var a:netaddr):boolean;
47 var
48 z,net,node,p:word;
49 t:string;
50 err:word;
51 begin
52 string2addrspe:=false;
53 s:=killspaceae(s)+'.';
54
55 val(copy(s,1,pos(':',s)-1),z,err);
56 if err<>0 then exit;
57 delete(s,1,pos(':',s));
58
59 val(copy(s,1,pos('/',s)-1),net,err);
60 if err<>0 then exit;
61 delete(s,1,pos('/',s));
62
63 val(copy(s,1,pos('.',s)-1),node,err);
64 if err<>0 then exit;
65 delete(s,1,pos('.',s));
66
67 if s='' then begin
68 end else begin
69 val(copy(s,1,pos('.',s)-1),p,err);
70 if err<>0 then exit;
71 delete(s,1,pos('.',s));
72 if s<>'' then exit;
73 a.point:=p;
74 end;
75 a.zone:=z;
76 a.node:=node;
77 a.net:=net;
78 string2addrspe:=true;
79 end;
array2stringnull80 function array2string(p:pchar;max:word):string;
81 var
82 s:string;
83 i:word;
84 begin
85 s:='';
86 for i:=0 to max-1 do begin
87 if p[i]=#0 then break;
88 s:=s+p[i];
89 end;
90 array2string:=s;
91 end;
92
transstringnull93 function transstring(s:string):string;
94 begin
95 if (length(s)>0) and (s[1]='"') then delete(s,1,1);
96 if (length(s)>0) and (s[length(s)]='"') then delete(s,length(s),1);
97 transstring:=s;
98 end;
99 procedure getfulladdr(var p:pchar;var size:longint;var o:netaddr;var d:netaddr);
100 var
101 s:String;
102 t:string;
103 i:longint;
104 k,j:longint;
105 ziel:pchar;
106 begin
107 i:=0; j:=0;
108 s:='';
109 ziel:=getmemory(size+1000);
110 while p[i]<>#0 do begin
111 s:=s+p[i];
112 inc(i);
113 if (p[i]=#1) or (p[i]=#0) then begin
114 if copy(s,1,6)=#1'INTL ' then begin
115 delete(s,1,6);
116 t:=killspaceae(copy(s,1,pos(' ',s)));
117 string2addrspe(t,d);
118 delete(s,1,pos(' ',s));
119 string2addrspe(killspaceae(s),o);
120 s:='';
121 continue;
122 end;
123 if copy(s,1,6)=#1'TOPT ' then begin
124 delete(s,1,6);
125 d.point:=s2z(s);
126 s:='';
127 continue;
128 end;
129 if copy(s,1,6)=#1'FMPT ' then begin
130 delete(s,1,6);
131 o.point:=s2z(s);
132 s:='';
133 continue;
134 end;
135 {if copy(s,1,8)=#1'MSGID: ' then begin s:=''; continue; end;}
136 for k:=1 to length(s) do begin
137 ziel[j]:=s[k]; inc(j);
138 end;
139 s:='';
140 end;
141 end;
142 ziel[j]:=#0;
143 freememory(p,true);
144 size:=j-1;
145 p:=ziel;
146 end;
147
148 procedure writelnspe(p:pchar);
149 var
150 i:longint;
151 begin
152 i:=0;
153 while p[i]<>#0 do begin
154 case p[i] of
155 #1:write('#');
156 else begin
157 write(p[i]);
158 end
159 end;
160 inc(i);
161 end;
162 writeln;
163 end;
164
longint2hexnull165 function longint2hex(l:longint):string;
166 const
167 conv:string='0123456789ABCDEF';
168 var
169 s:string;
170 i:integer;
171 begin
172 s:='';
173 for i:=1 to 8 do begin
174 s:=conv[(l and $f)+1]+s;
175 l:=l shr 4;
176 end;
177 longint2hex:=s;
178 end;
179
msgidnull180 function msgid:longint;
181 { Year Mon Day Hour Min Sec Counter}
182 {BITS 3 4 5 5 6 6 3 }
183 {The Msgid is unique at least for 7 Years}
184 {I can only gernate 7 unique Msgid per Sec}
185 var
186 y,m,d,dow:word;
187 h,min,sec,s100:word;
188
189 var
190 l:longint;
191 begin
192 repeat
193 {$ifdef __GPC__}
194 y:=0; m:=0; d:=0; dow:=0; h:=0; min:=0; sec:=0; s100:=0;
195 {$else}
196 getdate(y,m,d,dow);
197 gettime(h,min,sec,s100);
198 {$endif}
199
200 l:=((longint(y) mod 7) shl 29) or
201 (longint(m) shl 25) or
202 (longint(d) shl 20) or
203 (longint(h) shl 15) or
204 (longint(min) shl 9) or
205 (longint(sec) shl 3);
206 if (l=(lastmsgid and $fffffff8)) then begin
207 if (lastmsgid and 7)=7 then continue;
208 l:=lastmsgid+1;
209 end;
210 break;
211 until false;
212 lastmsgid:=l;
213 msgid:=l;
214 end;
215
216 procedure datetime2ftsdate(var date,time:word;var fts:array of char);
217 const
218 day:array[0..6] of string=('Sun','Mon','Tue', 'Wed','Thu','Fri','Sat');
219 month:array[1..12] of string= ('Jan' , 'Feb' , 'Mar' , 'Apr'
220 , 'May' , 'Jun' , 'Jul' , 'Aug'
221 , 'Sep' , 'Oct' , 'Nov' , 'Dec');
222 var
223 y,m,d,dow:word;
224 h,min,sec,s100:word;
225 s:String;
226 i:word;
227 begin
228 {$ifdef __GPC__}
229 y:=0; m:=0; d:=0; dow:=0; h:=0; min:=0; sec:=0; s100:=0;
230 {$else}
231 getdate(y,m,d,dow);
232 gettime(h,min,sec,s100);
233 {$endif}
234 time:=(sec div 2)+(min shl 5)+(h shl 11);
235 date:=d+(m shl 5)+((y-1980) shl 9);
236 fillchar(fts,sizeof(fts),0);
237 { s:=day[dow]+', '+z2s_nullen(d,2)+' '+month[m]+' '+z2s(y)+' '+z2s_nullen(h,2)+':'+z2s_nullen(min,2)+':'+z2s_nullen(sec,2)+' +0100';}
238 s:=z2s_nullen(d,2)+' '+month[m]+' '+z2s_nullen(y mod 100,2)+' '+z2s_nullen(h,2)+':'+z2s_nullen(min,2)+':'+z2s_nullen(sec,2);
239 for i:=1 to length(s) do begin
240 fts[i-1]:=s[i]; if i=20 then break;
241 end;
242 end;
243
showaddrnull244 function showaddr(a:netaddr):string;
245 begin
246 showaddr:=z2s(a.zone)+':'+z2s(a.net)+'/'+z2s(a.node)+'.'+z2s(a.point);
247 end;
248
showtimenull249 function showtime(time:word):string;
250 var
251 h,min,s,d,mon,y:word;
252 begin
253 word2timedate(time,0,h,min,s,d,mon,y);
254 showtime:= z2s_nullen(h,2)+':'+
255 z2s_nullen(min,2)+':'+
256 z2s_nullen(s,2);
257 end;
258
showdatenull259 function showdate(date:word):string;
260 var
261 h,min,s,d,mon,y:word;
262 begin
263 word2timedate(0,date,h,min,s,d,mon,y);
264 showdate:=z2s_nullen(d,2)+'.'+
265 z2s_nullen(mon,2)+'.'+
266 z2s(y);
267 end;
268
showdatetimenull269 function showdatetime(date:word;time:word):string;
270 var
271 h,min,s,d,mon,y:word;
272 begin
273 word2timedate(time,date,h,min,s,d,mon,y);
274 showdatetime:=z2s_nullen(d,2)+'.'+
275 z2s_nullen(mon,2)+'.'+
276 z2s(y)+' '+
277 z2s_nullen(h,2)+':'+
278 z2s_nullen(min,2)+':'+
279 z2s_nullen(s,2);
280 end;
281
282 procedure word2timedate(time:word;date:word;var h,min,s:word; var d,mon,y:word);
283 begin
284 s:=(time and 31)*2;
285 min:=(time shr 5) and 63;
286 h:=(time shr 11) and 31;
287
288 d:=date and 31;
289 mon:=(date shr 5) and 15;
290 y:=((date shr 9) and 127)+1980 {Years since 1980!?};
291 end;
292
string2addrnull293 function string2addr(s:String;var a:netaddr):boolean;
294 var
295 z,net,node,p:word;
296 t:string;
297 err:word;
298 begin
299 p:=0;
300 string2addr:=false;
301 s:=killspaceae(s)+'.';
302
303 val(copy(s,1,pos(':',s)-1),z,err);
304 if err<>0 then exit;
305 delete(s,1,pos(':',s));
306
307 val(copy(s,1,pos('/',s)-1),net,err);
308 if err<>0 then exit;
309 delete(s,1,pos('/',s));
310
311 val(copy(s,1,pos('.',s)-1),node,err);
312 if err<>0 then exit;
313 delete(s,1,pos('.',s));
314
315 if s='' then begin
316 p:=0
317 end else begin
318 val(copy(s,1,pos('.',s)-1),p,err);
319 if err<>0 then exit;
320 delete(s,1,pos('.',s));
321 if s<>'' then exit;
322 end;
323 a.zone:=z;
324 a.node:=node;
325 a.net:=net;
326 a.point:=p;
327 string2addr:=true;
328 end;
329
330 end.
331