1 Unit GeneralP;
2 {Version 1.2}
3 interface
4 uses
5 {$IfNDef GPC}
6   DOS,
7 {$EndIf}
8 {$IfDef SPEED}
9   BseDOS, BseDev,
10 {$EndIf}
11 {$IfDef VIRTUALPASCAL}
12  {Use32,} OS2Base, OS2Def,
13 {$EndIf}
14 {$IfDef LINUX}
15   Linux,
16 {$EndIf}
17   Strings,
18   Types;
19 
20 Const
21 {$IfDef LINUX}
22   DirSep = '/';
23 {$Else}
24   DirSep = '\';
25 {$EndIf}
26 
27 {$IfDef GPC}
28   pi = 3.14159265358979323846;
29   MaxLongInt = MaxInt;
30 {$EndIf}
31 
32   Leer='                                                                                      ';
33   C1970 = 2440588;
34   D0 =    1461;
35   D1 =  146097;
36   D2 = 1721119;
37   Digits = ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9'];
38   WkDaysEng  : Array[0..6] of String[9] = ('Sunday', 'Monday', 'Tuesday', 'Wednesday', 'Thursday', 'Friday', 'Saturday');
39   WkDaysGer  : Array[0..6] of String[10] = ('Sonntag', 'Montag', 'Dienstag', 'Mittwoch', 'Donnerstag', 'Freitag', 'Samstag');
40   WkDays3Eng : Array[0..6] of String[3] = ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
41   WkDays2Eng : Array[0..6] of String[2] = ('Su', 'Mo', 'Tu', 'We', 'Th', 'Fr', 'Sa');
42   WkDays3Ger : Array[0..6] of String[3] = ('Son', 'Mon', 'Die', 'Mit', 'Don', 'Fre', 'Sam');
43   WkDays2Ger : Array[0..6] of String[2] = ('So', 'Mo', 'Di', 'Mi', 'Do', 'Fr', 'Sa');
44   MonthsEng  : Array[1..12] of String[9] = ('January', 'February', 'March', 'April', 'May', 'June',
45                                             'July', 'August', 'September', 'October', 'November', 'December');
46   MonthsGer  : Array[1..12] of String[9] = ('Januar', 'Februar', 'M�rz', 'April', 'Mai', 'Juni',
47                                             'Juli', 'August', 'September', 'Oktober', 'November', 'Dezember');
48   Months3Eng : Array[1..12] of String[3] = ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
49                                             'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
50   Months3Ger : Array[1..12] of String[3] = ('Jan', 'Feb', 'M�r', 'Apr', 'Mai', 'Jun',
51                                             'Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez');
52 
53       CRC16Tab : ARRAY[0..255] OF WORD = (
54       $0000, $1021, $2042, $3063, $4084, $50a5, $60c6, $70e7,
55       $8108, $9129, $a14a, $b16b, $c18c, $d1ad, $e1ce, $f1ef,
56       $1231, $0210, $3273, $2252, $52b5, $4294, $72f7, $62d6,
57       $9339, $8318, $b37b, $a35a, $d3bd, $c39c, $f3ff, $e3de,
58       $2462, $3443, $0420, $1401, $64e6, $74c7, $44a4, $5485,
59       $a56a, $b54b, $8528, $9509, $e5ee, $f5cf, $c5ac, $d58d,
60       $3653, $2672, $1611, $0630, $76d7, $66f6, $5695, $46b4,
61       $b75b, $a77a, $9719, $8738, $f7df, $e7fe, $d79d, $c7bc,
62       $48c4, $58e5, $6886, $78a7, $0840, $1861, $2802, $3823,
63       $c9cc, $d9ed, $e98e, $f9af, $8948, $9969, $a90a, $b92b,
64       $5af5, $4ad4, $7ab7, $6a96, $1a71, $0a50, $3a33, $2a12,
65       $dbfd, $cbdc, $fbbf, $eb9e, $9b79, $8b58, $bb3b, $ab1a,
66       $6ca6, $7c87, $4ce4, $5cc5, $2c22, $3c03, $0c60, $1c41,
67       $edae, $fd8f, $cdec, $ddcd, $ad2a, $bd0b, $8d68, $9d49,
68       $7e97, $6eb6, $5ed5, $4ef4, $3e13, $2e32, $1e51, $0e70,
69       $ff9f, $efbe, $dfdd, $cffc, $bf1b, $af3a, $9f59, $8f78,
70       $9188, $81a9, $b1ca, $a1eb, $d10c, $c12d, $f14e, $e16f,
71       $1080, $00a1, $30c2, $20e3, $5004, $4025, $7046, $6067,
72       $83b9, $9398, $a3fb, $b3da, $c33d, $d31c, $e37f, $f35e,
73       $02b1, $1290, $22f3, $32d2, $4235, $5214, $6277, $7256,
74       $b5ea, $a5cb, $95a8, $8589, $f56e, $e54f, $d52c, $c50d,
75       $34e2, $24c3, $14a0, $0481, $7466, $6447, $5424, $4405,
76       $a7db, $b7fa, $8799, $97b8, $e75f, $f77e, $c71d, $d73c,
77       $26d3, $36f2, $0691, $16b0, $6657, $7676, $4615, $5634,
78       $d94c, $c96d, $f90e, $e92f, $99c8, $89e9, $b98a, $a9ab,
79       $5844, $4865, $7806, $6827, $18c0, $08e1, $3882, $28a3,
80       $cb7d, $db5c, $eb3f, $fb1e, $8bf9, $9bd8, $abbb, $bb9a,
81       $4a75, $5a54, $6a37, $7a16, $0af1, $1ad0, $2ab3, $3a92,
82       $fd2e, $ed0f, $dd6c, $cd4d, $bdaa, $ad8b, $9de8, $8dc9,
83       $7c26, $6c07, $5c64, $4c45, $3ca2, $2c83, $1ce0, $0cc1,
84       $ef1f, $ff3e, $cf5d, $df7c, $af9b, $bfba, $8fd9, $9ff8,
85       $6e17, $7e36, $4e55, $5e74, $2e93, $3eb2, $0ed1, $1ef0);
86 
87 Var
88  FilePerm: Word; {Permission used for created files under Linux}
89  DirPerm: Word; {Permission used for created directories under Linux}
90  ChangePerm: Boolean; {change permissions when copying or moving files?}
91 
92 
93 {$IfDef GPC}
94 Procedure Assign ( Var T: Text; Name: String255 );
95 Procedure FillChar ( Var Dest: Void; Count: Integer; C: Char );
ParamCountnull96 Function ParamCount: Integer;  (* This is stupid. *)
ParamStrnull97 Function ParamStr ( i: Integer ): String255;
GetEnvnull98 Function GetEnv ( Entry: String255 ): String255;
UpCasenull99 Function UpCase ( Ch: Char ): Char;
StrPasnull100 function StrPas(Src: CString): String255;
StrPCopynull101 function StrPCopy(Dest: CString; Src: String): CString;
Execnull102 Function Exec(prog, params: String255): Integer;
103 {$EndIf GPC}
104 
105 Procedure Delay(secs: Word);
106 
107 {$IfNDef SPEED}
108 Procedure GetFTime2(var f; var Year, Month, Day, Hour, Min, Sec: Word);
109 {$EndIf}
110 
LowCasenull111 Function LowCase(Ch:Char) : Char;
UpStrnull112 Function UpStr(_Str: String255) : String255;
LowStrnull113 Function LowStr(_Str: String255) : String255;
Date2Strnull114 Function Date2Str(Date: TimeTyp) : String10;
Time2Strnull115 Function Time2Str(Time: TimeTyp) : String10;
Str2Datenull116 Function Str2Date(_Str:String255; var Date:TimeTyp):boolean;
Str2Timenull117 Function Str2Time(_Str:String255; var Time:TimeTyp):boolean;
118 Procedure Today(var Date : TimeTyp);
119 Procedure Now(var Time : TimeTyp);
statusbarnull120 FUNCTION statusbar(total,aktuell:LONGINT; Laenge:BYTE):STRING255;
WordToHexnull121 Function WordToHex(w: Word):String4;
122 Procedure FileList(Start: String255; FileSpec : Byte);
LowerOfnull123 Function LowerOf(a, b : LongInt) : LongInt;
TimeDiffnull124 Function TimeDiff(Time1, Time2 : TimeTyp): LongInt; {in Sekunden}
KillLeadingSpcsnull125 Function KillLeadingSpcs(s: String255): String255;
KillTrailingSpcsnull126 Function KillTrailingSpcs(s: String255): String255;
KillSpcsnull127 Function KillSpcs(s: String): String;
AddDirSepnull128 Function AddDirSep(s: String255): String255;
GregorianToJuliannull129 Function GregorianToJulian(DT: TimeTyp): ULong;
130 Procedure JulianToGregorian(JulianDN : ULong; Var Year, Month, Day : Word);
131 Procedure UnixToDt(SecsPast: ULong; Var Dt: TimeTyp);
DTToUnixDatenull132 Function DTToUnixDate(DT: TimeTyp): ULong;
DTToUnixStrnull133 Function DTToUnixStr(DT: TimeTyp): String20;
DTToUnixHexStrnull134 Function DTToUnixHexStr(DT: TimeTyp): String8;
ToUnixDatenull135 Function ToUnixDate(FDate: LongInt): ULong;
IntToStrnull136 Function IntToStr(x: LongInt):String255;
IntToStr0null137 Function IntToStr0(x: LongInt):String255;
IntToStr03null138 Function IntToStr03(x: Word):String3;
StrToIntnull139 Function StrToInt(s: String255): LongInt;
OctalStrToIntnull140 Function OctalStrToInt(s: String255): LongInt;
FileExistnull141 Function FileExist(fn: String255):Boolean;
DirExistnull142 Function DirExist(fn: String255):Boolean;
LastPosnull143 Function LastPos(SubStr, S: String255): Byte;
MakeDirnull144 Function MakeDir(Dir: String128): Boolean;
RepEnvnull145 Function RepEnv(s: String255):String255;
Translatenull146 Function Translate(s: String255; IChar, OChar: Char): String255;
DosAppendnull147 Function DosAppend(var f: File): Integer;
MoveFilenull148 Function MoveFile(OName, NName: String255): Boolean;
RepFilenull149 Function RepFile(OName, NName: String255): Boolean;
CopyFilenull150 Function CopyFile(OName, NName: String255): Boolean;
DelFilenull151 Function DelFile(Name: String255): Boolean;
TruncFilenull152 Function TruncFile(Name: String255): Boolean;
CreateSemnull153 Function CreateSem(Name: String255): Boolean;
154 Procedure GetFileTime(Name: String255; var Year, Month, Day, Hour, Min, Sec: Word);
GetFSizenull155 Function GetFSize(Name: String255): LongInt;
leapyearnull156 Function leapyear (c, y : Byte) : Boolean;
DaysInMonthnull157 Function DaysInMonth (DT:TimeTyp; m : Byte) : Byte;
DayOfYearnull158 Function DayOfYear (DT: TimeTyp) : Word;
CRC16null159 function CRC16(s:string255):word;
GetCRC16null160 Function GetCRC16(fn: String255): Word;
161 
162 implementation
163 
164 Const fCarry = $0001;
165 
166 
167 {$IfDef GPC}
168 
169 Procedure Assign ( Var T: Text; Name: String255 );
170 Var
171   B: BindingType;
172 
173 begin
174   unbind ( T );
175   B:= binding ( T );
176   B.Name:= Name + chr ( 0 );
177   bind ( T, B );
178   B:= binding ( T );
179 end
180 
181 Procedure FillChar ( Var Dest: Void; Count: Integer; C: Char );
182 
183 Type
184   BytePtr = ^Byte;
185 
186 Var
187   p, q: BytePtr;
188 
189 begin
190   {$W-}  (* Warning "dereferencing `void *' pointer" is a minor bug in GPC *)
191   p:= @Dest;
192   {$W+}
193   q:= BytePtr ( LongInt ( p ) + Count );
194   while LongInt ( p ) < LongInt ( q ) do
195     begin
196       p^:= ord ( C );
197       LongInt ( p ) := LongInt(p) + 1;
198     end
199 end
200 
rtsParamCountnull201 Function rtsParamCount: Integer;
202 AsmName '_p_paramcount';
203 
rtsParamStrnull204 Function rtsParamStr ( i: Integer; Var S: String255 ): Boolean;
205 AsmName '_p_paramstr';
206 
207 
ParamCountnull208 Function ParamCount: Integer;
209 begin
210   ParamCount:= rtsParamCount - 1;
211 end
212 
213 
ParamStrnull214 Function ParamStr ( i: Integer ): String255;
215 Var
216   S: String255;
217 begin
218   if rtsParamStr ( i, S ) then
219     ParamStr:= Trim ( S )
220   else
221     ParamStr:= '';
222 end;
223 
224 
CGetEnvnull225 Function CGetEnv ( Entry: __CString__ ): PChar;
226 AsmName 'getenv';
227 
228 
GetEnvnull229 Function GetEnv ( Entry: String255 ): String255;
230 Var
231   C: PChar;
232   Contents: String255;
233 
234 begin
235   C:= CGetEnv ( Entry );
236   Contents:= '';
237   if C <> Nil then
238     while ( C^ <> chr ( 0 ) )
239      and ( length ( Contents ) < Contents.Capacity ) do
240       begin
241         Contents:= Contents + C^;
242         LongInt ( C ) := LongInt(C)+1;
243       end
244   GetEnv:= Contents;
245 end;
246 
UpCasenull247 Function UpCase ( Ch: Char ): Char;
248 begin
249   if ( Ch >= 'a' ) and ( Ch <= 'z' ) then
250     dec ( Ch, ord ( 'a' ) - ord ( 'A' ) );
251   UpCase:= Ch;
252 end;
253 
254 { Convert a "C" string to a "Pascal" string }
StrPasnull255 function StrPas(Src: CString): String255;
256 var
257  S : String255;
258 
259  begin
260  S := '';
261  if (Src <> NIL) then while ( (Src^ <> chr(0)) AND (length(S) < S.capacity)) do
262   begin
263   S := S + Src^;
264   Word(Src) := Word(Src)+1;
265   end;
266  StrPas := S;
267  end;
268 
269 { Convert a "Pascal" string to a "C" string }
StrPCopynull270 function StrPCopy(Dest: CString; Src: String): CString;
271 var
272  c: integer;
273  p: CString;
274 
275  begin
276  p := Dest;
277  for c:=1 to length(Src) do
278   begin
279   p^ := Src[c];
280   word(p) := word(p)+1;
281   end;
282  p^ := chr(0);
283  StrPCopy := Dest;
284  end;
285 
systemnull286 function system(name : CString): integer; C;
287 
Execnull288 Function Exec(prog, params: String255): Integer;
289 var
290  pName: CString;
291 
292  begin
293  getmem(pName, 256);
294  pName := StrPCopy(pName, prog+params);
295  Exec := system(pName);
296  freemem(pName, 256);
297  end;
298 
_itoanull299 Function _itoa (value: integer; s: cstring; radix: integer): CString; C;
_ltoanull300 Function _ltoa (value: LongInt; s: cstring; radix: integer): CString; C;
_ultoanull301 Function _ultoa (value: ULong; s: cstring; radix: integer): CString; C;
302 
303 {$ENDIF GPC}
304 
305 
306 Procedure Delay(secs: Word);
307 Var
308  i: Word;
309 
310  Begin
311  {bogus delay}
312  For i := 1 to 10000 do Write;
313  End;
314 
315 
LowCasenull316 Function LowCase(Ch:Char):Char;
317  Begin
318  if (Ch >= 'A') and (Ch <= 'Z') then LowCase := Char(Byte(Ch) + 32)
319  Else LowCase := Ch;
320  End;
321 
UpStrnull322 Function UpStr(_Str:String255) : String255;
323 Var
324  s:String255;
325  i:Byte;
326 
327  Begin
328  s := _str;
329  For i:= 1 to Length(_str) do s[i]:=UpCase(_str[i]);
330  UpStr:= s;
331  End;
332 
LowStrnull333 Function LowStr(_Str:String255) : String255;
334 Var
335  s:String255;
336  i:Byte;
337 
338  Begin
339  s[0] := _str[0];
340  For i:= 1 to Length(_str) do s[i]:= LowCase(_str[i]);
341  LowStr:= s;
342  End;
343 
Date2Strnull344 Function Date2Str(Date:TimeTyp) : String10;
345 var
346  s,s2:String[10];
347  i: Byte;
348 
349 begin
350 s2 := IntToStr(Date.Day);
351 If (length(s2) < 2) then s2 := '0'+s2
352 Else If (s2[1] = ' ') then s2[1] := '0';
353 s:=s2+'.';
354 s2 := IntToStr(Date.Month);
355 If (length(s2) < 2) then s2 := '0'+s2
356 Else If (s2[1] = ' ') then s2[1] := '0';
357 s:=s+s2+'.';
358 s2 := IntToStr(Date.Year);
359 If (length(s2) < 4) then
360  Begin
361  for i := 1 to (4 - length(s2)) do s2 := '0' + s2;
362  If (s2[4] = ' ') then s2[4] := '0';
363  End
364 Else
365  Begin
366  If (s2[1] = ' ') then s2[1] := '0';
367  If (s2[2] = ' ') then s2[2] := '0';
368  If (s2[3] = ' ') then s2[3] := '0';
369  If (s2[4] = ' ') then s2[4] := '0';
370  End;
371 Date2Str:=s+s2;
372 end;
373 
Time2Strnull374 Function Time2Str(Time:TimeTyp) : String10;
375 var s,s2:String[10];
376 begin
377 s2 := IntToStr(Time.Hour);
378 If (length(s2) < 2) then s2 := '0'+s2
379 Else If (s2[1] = ' ') then s2[1] := '0';
380 s:=s2+':';
381 s2 := IntToStr(Time.Min);
382 If (length(s2) < 2) then s2 := '0'+s2
383 Else If (s2[1] = ' ') then s2[1] := '0';
384 s:=s+s2+':';
385 s2 := IntToStr(Time.Sec);
386 If (length(s2) < 2) then s2 := '0'+s2
387 Else If (s2[1] = ' ') then s2[1] := '0';
388 Time2Str:=s+s2;
389 end;
390 
Str2Datenull391 Function Str2Date(_Str:String255; var Date:TimeTyp):boolean;
392 var
393  OK:boolean;
394 {$IfDef VIRTUALPASCAL}
395   Error:LongInt;
396 {$Else}
397   Error:integer;
398 {$EndIf}
399 
400 begin
401 OK:=Pos('.', _Str)=3;
402 If OK then begin
403    Val(Copy(_Str, 1, 2), Date.Day, Error);
404    Delete(_Str, 1, 3);
405    OK:=(Pos('.', _Str)=3) and (Error=0);
406    If OK then begin
407       Val(Copy(_Str, 1, 2), Date.Month, Error);
408       Delete(_Str, 1, 3);
409       OK:=(Error=0);
410       If OK then Val(Copy(_Str, 1, 4), Date.Year, Error);
411       OK:=(Error=0);
412       end;
413    end;
414 Str2Date:=OK;
415 end;
416 
Str2Timenull417 Function Str2Time(_Str:String255; var Time:TimeTyp):boolean;
418 var
419  OK:boolean;
420 {$IfDef VIRTUALPASCAL}
421   Error:LongInt;
422 {$Else}
423   Error:integer;
424 {$EndIf}
425 
426 begin
427 OK:=(Pos(':', _Str)=3);
428 If OK then begin
429    Val(Copy(_Str, 1, 2), Time.Hour, Error);
430    Delete(_Str, 1, 3);
431    OK:=(Pos(':', _Str)=3) and (Error=0);
432    If OK then begin
433       Val(Copy(_Str, 1, 2), Time.Min, Error);
434       Delete(_Str, 1, 3);
435       OK:=(Error=0);
436       end;
437       If OK then begin
438          Val(Copy(_Str, 1, 2), Time.Sec, Error);
439          OK:=(Error=0);
440          end;
441    end;
442 Str2Time:=OK;
443 end;
444 
445 {$IfDef VIRTUALPASCAL}
446 Procedure Today(var Date : TimeTyp);
447 Var
448  Y, M, D, DOW: LongInt;
449 begin
450 GetDate(Y, M, D, DOW);
451 With Date do
452  Begin
453  Year := Y;
454  Month := M;
455  Day := D;
456  DayOfWeek := DOW;
457  End;
458 end;
459 {$Else}
460 Procedure Today(var Date : TimeTyp);
461 begin
462 With Date do DOS.GetDate(Year, Month, Day, DayOfWeek);
463 end;
464 {$EndIf}
465 
466 {$IfDef VIRTUALPASCAL}
467 Procedure Now(var Time : TimeTyp);
468 Var
469  H, M, S, S100: LongInt;
470 
471 begin
472 GetTime(H, M, S, S100);
473 With Time do
474  Begin
475  Hour := H;
476  Min := M;
477  Sec := S;
478  Sec100 := S100;
479  End;
480 end;
481 {$Else}
482 Procedure Now(var Time : TimeTyp);
483 begin
484 With Time do DOS.GetTime(Hour, Min, Sec, Sec100);
485 end;
486 {$EndIf}
487 
statusbarnull488 FUNCTION statusbar(total,aktuell:LONGINT; Laenge:BYTE):STRING255;
489 {*               kleine Fortschrittsanzeige                 *}
490 var i:LONGINT;
491     s:STRING255;
492     a:BYTE;
493 BEGIN
494   s[0]:=CHR(Laenge); a:=Round(aktuell/total*laenge);
495   FOR i:=1 to a DO s[i]:=#178; FOR i:=a+1 to laenge DO s[i]:=#176;
496   statusbar:=s;
497 END;
498 
WordToHexnull499 Function WordToHex(w: Word):String4;
500 const
501   hexChars: array [0..$F] of Char =
502     '0123456789abcdef';
503 begin
504 WordToHex:=hexChars[Hi(w) shr 4]+hexChars[Hi(w) and $F]+
505            hexChars[Lo(w) shr 4]+hexChars[Lo(w) and $F];
506 end;
507 
508 Procedure FileList(Start: String255; FileSpec : Byte);
509 Var
510   SRec: SearchRec;
511 Begin
512   WriteLn(Start);
513   FindFirst(Start + DirSep + '*.*', FileSpec, SRec);
514   While (DOS.DosError = 0) Do Begin
515     If ((SRec.Attr And FileSpec) > 0)
516        And not ((SRec.Name = '.') or (SRec.Name = '..')) Then FileList(Start + DirSep + SRec.Name, FileSpec);
517     FindNext(SRec);
518     End;
519 End;
520 
LowerOfnull521 Function LowerOf(a, b : LongInt): LongInt;
522 begin
523 If a < b then LowerOf := a Else LowerOf := b;
524 end;
525 
TimeDiffnull526 Function TimeDiff(Time1, Time2 : TimeTyp): LongInt; {in Sekunden}
527 var TDiff : LongInt;
528 begin
529 TDiff:=LongInt(LongInt(Time1.Hour) - LongInt(Time2.Hour)) * 3600;
530 TDiff:=TDiff + LongInt(LongInt(Time1.Min) - LongInt(Time2.Min)) * 60;
531 TDiff:=TDiff + LongInt(LongInt(Time1.Sec) - LongInt(Time2.Sec));
532 TimeDiff:= Abs(TDiff);
533 end;
534 
KillLeadingSpcsnull535 Function KillLeadingSpcs(s: String255):String255;
536   Begin
537   While (s[1] = ' ') and (Length(s) > 0) do Delete(s, 1, 1);
538   KillLeadingSpcs := s;
539   End;
540 
KillTrailingSpcsnull541 Function KillTrailingSpcs(s: String255):String255;
542   Begin
543   While (s[Length(s)] = ' ') and (Length(s) > 0) do Delete(s, Length(s), 1);
544   KillTrailingSpcs := s;
545   End;
546 
KillSpcsnull547 Function KillSpcs(s: String): String; {kill leading and trailing spaces}
548  Begin
549  While (s[1] in [' ', #9]) and (Length(s) > 0) do Delete(s, 1, 1);
550  While (s[Length(s)] in [' ', #9]) and (Length(s) > 0) do Delete(s, Length(s), 1);
551  KillSpcs := s;
552  End;
553 
AddDirSepnull554 Function AddDirSep(s: String255): String255;
555  Begin
556  If (s[Byte(s[0])] <> DirSep) then AddDirSep := s + DirSep
557  Else AddDirSep := s;
558  End;
559 
GregorianToJuliannull560 Function GregorianToJulian(DT: TimeTyp): ULong;
561 Var
562   Century: ULong;
563   XYear: ULong;
564   Temp: ULong;
565   Month: ULong;
566 
567   Begin
568   Month := DT.Month;
569   If Month <= 2 Then
570     Begin
571     Dec(DT.Year);
572     Month := Month + 12;
573     End;
574   Dec(Month,3);
575   Century := DT.Year Div 100;
576   XYear := DT.Year Mod 100;
577   Century := (Century * D1) shr 2;
578   XYear := (XYear * D0) shr 2;
579   GregorianToJulian :=  ((((Month * 153) + 2) div 5) + DT.Day) + D2
580     + XYear + Century;
581   End;
582 
583 Procedure JulianToGregorian(JulianDN : ULong; Var Year, Month,
584   Day : Word);
585 
586   Var
587     Temp,
588     XYear: ULong;
589     YYear,
590     YMonth,
591     YDay: Integer;
592 
593   Begin
594   Temp := (((JulianDN - D2) shl 2) - 1);
595   XYear := (Temp Mod D1) or 3;
596   JulianDN := Temp Div D1;
597   YYear := (XYear Div D0);
598   Temp := ((((XYear mod D0) + 4) shr 2) * 5) - 3;
599   YMonth := Temp Div 153;
600   If YMonth >= 10 Then
601     Begin
602     YYear := YYear + 1;
603     YMonth := YMonth - 12;
604     End;
605   YMonth := YMonth + 3;
606   YDay := Temp Mod 153;
607   YDay := (YDay + 5) Div 5;
608   Year := YYear + (JulianDN * 100);
609   Month := YMonth;
610   Day := YDay;
611   End;
612 
613 Procedure UnixToDt(SecsPast: ULong; Var Dt: TimeTyp);
614   Var
615     DateNum: ULong;
616 
617   Begin
618   Datenum := (SecsPast Div 86400) + c1970;
619   JulianToGregorian(DateNum, DT.Year, DT.Month, DT.day);
620   SecsPast := SecsPast Mod 86400;
621   DT.Hour := SecsPast Div 3600;
622   SecsPast := SecsPast Mod 3600;
623   DT.Min := SecsPast Div 60;
624   DT.Sec := SecsPast Mod 60;
625   End;
626 
DTToUnixDatenull627 Function DTToUnixDate(DT: TimeTyp): ULong;
628    Var
629      SecsPast, DaysPast: ULong;
630 
631   Begin
632   DaysPast := GregorianToJulian(DT) - c1970;
633   SecsPast := DT.Sec + ULong(DT.Min)*60 + ULong(DT.Hour)*3600 + DaysPast*86400;
634   DTToUnixDate := SecsPast;
635   End;
636 
ToUnixDatenull637 Function ToUnixDate(FDate: LongInt): ULong;
638   Var
639 {$IfDef VIRTUALPASCAL}
640       DT: DOS.DateTime;
641 {$Else}
642       DT: DateTime;
643 {$EndIf}
644       DT2: TimeTyp;
645 
646   Begin
647   UnpackTime(Fdate, Dt);
648   dt2.Day := dt.day;
649   dt2.Month := dt.Month;
650   dt2.Year := dt.Year;
651   dt2.Hour := dt.Hour;
652   dt2.Min := dt.Min;
653   dt2.Sec := dt.Sec;
654   dt2.Sec100 := 0;
655   ToUnixDate := DTToUnixDate(Dt2);
656   End;
657 
DTToUnixStrnull658 Function DTToUnixStr(DT: TimeTyp): String20;
659 Var
660   s : String[20];
661 
662   Begin
663   Str(DTToUnixDate(DT), s);
664   DTToUnixStr := s;
665   End;
666 
DTToUnixHexStrnull667 Function DTToUnixHexStr(DT: TimeTyp): String8;
668 Var
669   s : String[20];
670   i: ULong;
671 
672   Begin
673   i := DTToUnixDate(DT);
674   s := WordToHex(word(i SHR 16)) + WordToHex(word(i));
675   DTToUnixHexStr := s;
676   End;
677 
IntToStrnull678 Function IntToStr(x: LongInt):String255;
679 Var
680   s : String255;
681 {$IfDef GPC}
682   cs: CString;
683 {$EndIf}
684 
685   Begin
686 {$IfDef GPC}
687   GetMem(cs, 256);
688   cs := _itoa(x, cs, 10);
689   s := StrPas(cs);
690   FreeMem(cs, 256);
691 {$Else}
692   Str(x, s);
693 {$EndIf}
694   IntToStr := s;
695   End;
696 
IntToStr0null697 Function IntToStr0(x: LongInt):String255;
698 Var
699   s : String255;
700   i: Byte;
701 
702   Begin
703   s := IntToStr(x);
704   For i := 1 to length(s) do if s[i] = ' ' then s[i] := '0';
705   IntToStr0 := s;
706   End;
707 
IntToStr03null708 Function IntToStr03(x: Word):String3;
709 Var
710   s : String[3];
711   i: Byte;
712 
713   Begin
714   s := IntToStr(x);
715   If (length(s) = 1) then s := '0'+s;
716   If (length(s) = 2) then s := '0'+s;
717   For i := 1 to 3 do if s[i] = ' ' then s[i] := '0';
718   IntToStr03 := s;
719   End;
720 
StrToIntnull721 Function StrToInt(s: String255): LongInt;
722 Var
723  x: LongInt;
724 {$IfDef VIRTUALPASCAL}
725  Error : LongInt;
726 {$Else}
727  Error : Integer;
728 {$EndIf}
729 
730  Begin
731  Val(s, x, Error);
732  If (Error <> 0) then StrToInt := 0 Else StrToInt := x;
733  End;
734 
OctalStrToIntnull735 Function OctalStrToInt(s: String255): LongInt;
736 Var
737  Result: LongInt;
738  CurPos: Byte;
739  Pot8: LongInt;
740  CurNum: Byte;
741  Error: Byte;
742 
743  Begin
744  Error := 0;
745  Result := 0;
746  Pot8 := 1;
747  for CurPos := length(s) downto 1 do
748    Begin
749    Case s[CurPos] of
750      '0': CurNum := 0;
751      '1': CurNum := 1;
752      '2': CurNum := 2;
753      '3': CurNum := 3;
754      '4': CurNum := 4;
755      '5': CurNum := 5;
756      '6': CurNum := 6;
757      '7': CurNum := 7;
758      '8': CurNum := 8;
759      '9': CurNum := 9;
760      else
761        Begin
762        CurNum := 0;
763        Error := CurPos;
764        End;
765      End;
766 
767    Result := Result + (Pot8 * CurNum);
768    Pot8 := Pot8 * 8;
769    End;
770  If (Error = 0) then OctalStrToInt := Result Else OctalStrToInt := -1;
771  End;
772 
FileExistnull773 Function FileExist(fn: String255):Boolean;
774 Var
775   f: File;
776 
777   Begin
778   Assign(f, fn);
779   {$I-} ReSet(f); {$I+}
780   If (IOResult = 0) then
781     Begin
782     {$I-} Close(f); {$I+}
783     FileExist := (IOResult <> 0) or (IOResult = 0);
784     End
785   Else FileExist := False;
786   End;
787 
DirExistnull788 Function DirExist(fn: String255):Boolean;
789 Var
790   SRec: SearchRec;
791 
792   Begin
793   If (fn[2] = ':') and (Length(fn) = 2) then DirExist := True
794   Else If (fn[2] = ':') and (fn[3] = '\') and (Length(fn) = 3) then DirExist := True
795   Else
796    Begin
797    FindFirst(fn, Directory, SRec);
798    DirExist := (DOS.DOSError = 0);
799 {$IfDef OS2}
800    FindClose(SRec);
801 {$EndIf}
802    End;
803   End;
804 
LastPosnull805 Function LastPos(SubStr, S: String255): Byte;
806 Var
807   i: Byte;
808   Begin
809   LastPos := 0;
810   For i := (Length(s)-Length(SubStr)) DownTo 1 do
811     If (Copy(s, i, Length(SubStr)) = SubStr) Then
812     Begin
813     LastPos := i;
814     Break;
815     End;
816   End;
817 
MakeDirnull818 Function MakeDir(Dir: String128): Boolean;
819   Begin
820   {$I-} MkDir(Dir); {$I+}
821   If (IOResult <> 0) Then
822     Begin
823     If (Pos(DirSep, Dir) <> 0) Then
824       Begin
825       MakeDir := MakeDir(Copy(Dir, 1, LastPos(DirSep, Dir) - 1));
826       {$I-} MkDir(Dir); {$I+}
827       If (IOResult = 0) then
828        Begin
829 {$IfDef Linux}
830        Chmod(Dir, DirPerm);
831 {$EndIf}
832        MakeDir := True;
833        End
834       Else MakeDir := False;
835       End
836     Else MakeDir := False;
837     End
838   Else
839    Begin
840 {$IfDef Linux}
841    Chmod(Dir, DirPerm);
842 {$EndIf}
843    MakeDir := True;
844    End;
845   End;
846 
RepEnvnull847 Function RepEnv(s: String255):String255;
848 Var
849   s1, s2, s3: String255;
850   i: Byte;
851 
852   Begin
853   s1 := s;
854   i := 1;
855   While (i < Length(s1)) do
856    Begin
857    If (s1[i] = '%') then
858     Begin
859     Delete(s1, i, 1);
860     If not (s1[i] = '%') then
861      Begin
862      s3 := Copy(s1, i, Length(s1)-i+1);
863      If ((Pos('%', s3) = 0) or
864       ((Pos(' ', s3) > 0) and (Pos(' ', s3) < Pos('%', s3)))) then
865       Begin
866       Insert('%', s1, i);
867       End
868      Else
869       Begin
870       s2 := Copy(s1, i, Pos('%', s1) - i);
871       Delete(s1, i, Pos('%', s1) - i + 1);
872       Insert(DOS.GetEnv(UpStr(s2)), s1, i);
873       End;
874      End;
875     End;
876    Inc(i);
877    End;
878   RepEnv := s1;
879   End;
880 
Translatenull881 Function Translate(s: String255; IChar, OChar: Char): String255;
882 Var
883   s1: String255;
884   i: Byte;
885 
886   Begin
887   If (IChar = OChar) then
888     Begin
889     Translate := s;
890     Exit;
891     End;
892   s1 := s;
893   i := Pos(IChar, s1);
894   While (i <> 0) do
895     Begin
896     s1[i] := OChar;
897     i := Pos(IChar, s1);
898     End;
899   Translate := s1;
900   End;
901 
902 
DosAppendnull903 Function DosAppend(var f: File): Integer;
904 Var
905  rc: Integer;
906 
907   Begin
908 {$IfDef SPEED}
909   {$I-} Append(f); {$I+}
910   If (IOResult <> 0) then
911    Begin
912    {$I-} ReWrite(f); {$I+}
913    DOSAppend := IOResult;
914    End
915   Else DosAppend := 0;
916 {$Else}
917   {$I-}
918   ReSet(f);
919   If (IOResult <> 0) then
920    Begin
921    ReWrite(f);
922    rc := IOResult;
923    DosAppend := rc;
924    End
925   Else
926    Begin
927    Seek(f, FileSize(f));
928    DosAppend := IOResult;
929    End;
930   {$I+}
931 {$EndIf}
932   End;
933 
MoveFilenull934 Function MoveFile(OName, NName: String255): Boolean;
935 {$IfDef SPEED}
936 Var
937   rc: APIRet;
938   cs1, cs2: CString;
939 
940   Begin
941   If FileExist(NName) then MoveFile := False
942   Else
943     Begin
944     cs1 := OName;
945     cs2 := NName;
946     rc := DosMove(cs1, cs2);
947     If (rc <> 0) then
948       Begin
949       rc := DosCopy(cs1, cs2, 0);
950       If (rc <> 0) then
951         Begin
952         MoveFile := False;
953         End
954       Else
955         Begin
956         rc := DosDelete(cs1);
957         MoveFile := (rc = 0);
958         End;
959       End
960     Else MoveFile := True;
961     End;
962   End;
963 
964 {$Else}
965  {$IfDef VIRTUALPASCAL}
966 Var
967   rc: LongInt;
968   cs1, cs2: PChar;
969 
970   Begin
971   If FileExist(NName) then MoveFile := False
972   Else
973     Begin
974     GetMem(cs1, 256);
975     GetMem(cs2, 256);
976     StrPCopy(cs1, OName);
977     StrPCopy(cs2, NName);
978     rc := DosMove(cs1, cs2);
979     If (rc <> 0) then
980       Begin
981       rc := DosCopy(cs1, cs2, 0);
982       If (rc <> 0) then
983         Begin
984         MoveFile := False;
985         End
986       Else
987         Begin
988         rc := DosDelete(cs1);
989         MoveFile := (rc = 0);
990         End;
991       End
992     Else MoveFile := True;
993     FreeMem(cs1, 256);
994     FreeMem(cs2, 256);
995     End;
996   End;
997 
998  {$Else}
999 
1000 Var
1001   f: File;
1002 
1003   Begin
1004   If FileExist(NName) then MoveFile := False
1005   Else
1006     Begin
1007     Assign(f, OName);
1008     {$I-} Rename(f, NName); {$I+}
1009     If ((IOResult <> 0) or not FileExist(NName)) then
1010       Begin
1011 {$IfDef LINUX}
1012       shell('cp '+OName+' '+NName);
1013       If ChangePerm then ChMod(NName, FilePerm);
1014 {$Else}
1015       SwapVectors;
1016       Exec(GetEnv('COMSPEC'), '/C copy '+OName+' '+NName);
1017       SwapVectors;
1018 {$EndIf}
1019       If (FileExist(OName) and FileExist(NName)) then
1020         Begin
1021         Assign(f, OName);
1022         {$I-} Erase(f); {$I+}
1023         MoveFile := (IOResult = 0);
1024         End
1025       Else MoveFile := False;
1026       End
1027     Else MoveFile := True;
1028     End;
1029   End;
1030  {$EndIf}
1031 {$EndIf}
1032 
RepFilenull1033 Function RepFile(OName, NName: String255): Boolean;
1034 {$IfDef SPEED}
1035 Var
1036   rc: APIRet;
1037   cs1, cs2: CString;
1038 
1039   Begin
1040   cs1 := OName;
1041   cs2 := NName;
1042   rc := DosMove(cs1, cs2);
1043   If (rc <> 0) then
1044     Begin
1045     rc := DosCopy(cs1, cs2, 1);
1046     If (rc <> 0) then
1047       Begin
1048       RepFile := False;
1049       End
1050     Else
1051       Begin
1052       rc := DosDelete(cs1);
1053       RepFile := (rc = 0);
1054       End;
1055     End
1056   Else RepFile := True;
1057   End;
1058 
1059 {$Else}
1060 Var
1061   f: File;
1062 
1063   Begin
1064   Assign(f, OName);
1065   {$I-} Rename(f, NName); {$I+}
1066   If ((IOResult <> 0) or not FileExist(NName)) then
1067     Begin
1068 {$IfDef LINUX}
1069     shell('cp '+OName+' '+NName);
1070     If ChangePerm then Chmod(NName, FilePerm);
1071 {$Else}
1072     SwapVectors;
1073     Exec(GetEnv('COMSPEC'), '/C copy '+OName+' '+NName);
1074     SwapVectors;
1075 {$EndIf}
1076     If (FileExist(OName) and FileExist(NName)) then
1077       Begin
1078       Assign(f, OName);
1079       {$I-} Erase(f); {$I+}
1080       RepFile := (IOResult = 0);
1081       End
1082     Else RepFile := False;
1083     End
1084   Else RepFile := True;
1085   End;
1086 {$EndIf}
1087 
CopyFilenull1088 Function CopyFile(OName, NName: String255): Boolean;
1089 {$IfDef SPEED}
1090 Var
1091   cs1, cs2: CString;
1092 
1093   Begin
1094   cs1 := OName;
1095   cs2 := NName;
1096   CopyFile := (DosCopy(cs1, cs2, 0) = 0);
1097   End;
1098 
1099 {$Else}
1100 
1101   Begin
1102 {$IfDef LINUX}
1103   shell('cp '+OName+' '+NName);
1104   If ChangePerm then Chmod(NName, FilePerm);
1105 {$Else}
1106   SwapVectors;
1107   Exec(GetEnv('COMSPEC'), '/C copy '+OName+' '+NName);
1108   SwapVectors;
1109 {$EndIf}
1110   CopyFile := FileExist(NName);
1111   End;
1112 {$EndIf}
1113 
DelFilenull1114 Function DelFile(Name: String255): Boolean;
1115 Var
1116   f: File;
1117 
1118   Begin
1119   Assign(f, Name);
1120   {$I-} Erase(f); {$I+}
1121   DelFile := ((IOResult = 0) and not FileExist(Name));
1122   End;
1123 
TruncFilenull1124 Function TruncFile(Name: String255): Boolean;
1125 Var
1126   f: File;
1127 
1128   Begin
1129   Assign(f, Name);
1130   {$I-} ReWrite(f); {$I+}
1131   If (IOResult = 0) then
1132    Begin
1133    {$I-} Close(f); {$I+}
1134    TruncFile := (IOResult = 0);
1135    End
1136   Else TruncFile := False;
1137   End;
1138 
CreateSemnull1139 Function CreateSem(Name: String255): Boolean;
1140 Var
1141   f: Text;
1142   i: Integer;
1143 
1144   Begin
1145   Assign(f, Name);
1146   {$I-} ReWrite(f); {$I+}
1147   If (IOResult = 0) then
1148    Begin
1149    {$I-} WriteLn(f); {$I+}
1150    i := IOResult;
1151    {$I-} Close(f); {$I+}
1152 {$IfDef Linux}
1153    Chmod(Name, FilePerm);
1154 {$EndIf}
1155    CreateSem := (IOResult = 0) and (i = 0);
1156    End
1157   Else CreateSem := False;
1158   End;
1159 
1160 {$IfNDef SPEED}
1161 Procedure GetFTime2(var f; var Year, Month, Day, Hour, Min, Sec: Word);
1162 Var
1163   i: LongInt;
1164 {$IfDef VIRTUALPASCAL}
1165   DT: DOS.DateTime;
1166 {$Else}
1167   DT: DateTime;
1168 {$EndIf}
1169 
1170   Begin
1171   GetFTime(f, i);
1172   UnPackTime(i, DT);
1173   Year := DT.Year;
1174   Month := DT.Month;
1175   Day := DT.Day;
1176   Hour := DT.Hour;
1177   Min := DT.Min;
1178   Sec := DT.Sec;
1179   End;
1180 {$EndIf}
1181 
1182 Procedure GetFileTime(Name: String255; var Year, Month, Day, Hour, Min, Sec: Word);
1183 Var
1184   f: File;
1185 
1186   Begin
1187   Assign(f, Name);
1188   {$I-} ReSet(f); {$I-}
1189   If (IOResult = 0) then
1190     Begin
1191     GetFTime2(f, Year, Month, Day, Hour, Min, Sec);
1192     {$I-} Close(f); {$I+}
1193     If (IOResult = 0) then ;
1194     End;
1195   End;
1196 
GetFSizenull1197 Function GetFSize(Name: String255): LongInt;
1198 Var
1199   f: File of Byte;
1200 
1201   Begin
1202   Assign(f, Name);
1203   {$I-} ReSet(f); {$I+}
1204   If (IOResult = 0) then
1205     Begin
1206     GetFSize := FileSize(f);
1207     {$I-} Close(f); {$I+}
1208     If (IOResult = 0) then ;
1209     End
1210   Else GetFSize := 0;
1211   End;
1212 
leapyearnull1213 Function leapyear (c, y : Byte) : Boolean;
1214 begin
1215   if (y and 3) <> 0 then
1216           leapyear := False
1217   else
1218         if y <> 0 then
1219           leapyear := True
1220   else
1221         if (c and 3) = 0 then
1222           leapyear := True
1223   else
1224           leapyear := False;
1225 end;
1226 
DaysInMonthnull1227 Function DaysInMonth (DT:TimeTyp; m : Byte) : Byte;
1228 begin
1229   if m = 2 then
1230           if leapyear(DT.Year div 100, DT.Year mod 100) then
1231                   DaysInMonth := 29
1232     else
1233                   DaysInMonth := 28
1234   else
1235           DaysInMonth := 30 + (($15AA shr m) and 1);
1236 end;
1237 
DayOfYearnull1238 Function DayOfYear (DT: TimeTyp) : Word;
1239 Var i, j : Integer;
1240 begin
1241   j := DT.Day;
1242   If (DT.Month > 1) then For i := 1 to pred(DT.Month) do
1243    j := j + DaysInMonth(DT,i);
1244   DayOfYear := j;
1245 end;
1246 
CRC16null1247 function CRC16(s:string255):word;  { By Kevin Cooney }
1248 var
1249   crc : longint;
1250   t,r : byte;
1251 begin
1252   crc:=0;
1253   for t:=1 to length(s) do
1254   begin
1255     crc:=(crc xor (ord(s[t]) shl 8));
1256     for r:=1 to 8 do
1257       if (crc and $8000)>0 then
1258         crc:=((crc shl 1) xor $1021)
1259           else
1260             crc:=(crc shl 1);
1261   end;
1262   CRC16:=(crc and $FFFF);
1263 end;
1264 
GetCRC16null1265 Function GetCRC16(fn: String255): Word;
1266 Type
1267  PBuff = ^TBuff;
1268  TBuff = Array[1..65530] of Byte;
1269 
1270 Var
1271  f: File;
1272  Buf: PBuff;
1273 {$IfDef SPEED}
1274  nr: LongWord;
1275 {$Else}
1276  {$IfDef VIRTUALPASCAL}
1277  nr: LongInt;
1278  {$Else}
1279  nr: Word;
1280  {$EndIf}
1281 {$EndIf}
1282  i, j: Word;
1283  CRC: Longint;
1284 
1285  Begin
1286  CRC := $0000;
1287  Assign(f, fn);
1288  {$I-} ReSet(f, 1); {$I+}
1289  If (IOResult <> 0) then
1290   Begin
1291   GetCRC16 := $FFFF;
1292   Exit;
1293   End;
1294  New(Buf);
1295   Repeat
1296   BlockRead(f, Buf^, 65530, nr);
1297   If (nr > 0) then
1298    Begin
1299    For i := 1 to nr do
1300     Begin
1301     crc:=(crc xor (ord(Buf^[i]) shl 8));
1302     for j:=1 to 8 do
1303      if (crc and $8000)>0 then crc:=((crc shl 1) xor $1021)
1304      else crc:=(crc shl 1);
1305     End;
1306    End;
1307   Until (nr < 65530);
1308  GetCRC16 := (CRC and $FFFF);
1309  Dispose(Buf);
1310  Close(f);
1311  End;
1312 
1313 Begin
1314 {$IfDef Linux}
1315 If (DOS.GetEnv('UMASK') <> '') then
1316  Begin
1317  FilePerm := OctalStrToInt(DOS.GetEnv('UMASK'));
1318  FilePerm := 511 and not FilePerm;
1319  DirPerm := FilePerm;
1320  End
1321 Else
1322  Begin
1323  FilePerm := 493; {octal 755}
1324  DirPerm := 493; {octal 755}
1325  End;
1326 {$Else}
1327 FilePerm := 0; DirPerm := 0;
1328 {$EndIf}
1329 ChangePerm := False;
1330 end.
1331 
1332