1 {$H-}
2 unit dmisc;
3
4 interface
5
6 {$ifndef linux}
7 {$define MSWindows}
8 {$endif}
9
10 uses
11 {$ifdef linux}
12 Libc,
13 {$else}
14 windows,
15 {$endif}
16 sysutils;
17
18 {$ifdef VER100}
19 type int64 = longint;
20 {$endif}
21
22 Const
23 Max_Path = 255;
24
25 {Bitmasks for CPU Flags}
26 fcarry = $0001;
27 fparity = $0004;
28 fauxiliary = $0010;
29 fzero = $0040;
30 fsign = $0080;
31 foverflow = $0800;
32
33 {Bitmasks for file attribute}
34 readonly = $01;
35 hidden = $02;
36 sysfile = $04;
37 volumeid = $08;
38 directory = $10;
39 archive = $20;
40 anyfile = $3F;
41
42 {File Status}
43 fmclosed = $D7B0;
44 fminput = $D7B1;
45 fmoutput = $D7B2;
46 fminout = $D7B3;
47
48
49 Type
50 DWord = Cardinal;
51
52 { Needed for Win95 LFN Support }
53 ComStr = String[255];
54 PathStr = String[255];
55 DirStr = String[255];
56 NameStr = String[255];
57 ExtStr = String[255];
58
59 FileRec = TFileRec;
60
61 DateTime = packed record
62 Year,
63 Month,
64 Day,
65 Hour,
66 Min,
67 Sec : word;
68 End;
69
70 SearchRec = Sysutils.TSearchRec;
71
72 registers = packed record
73 case i : integer of
74 0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
75 1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte);
76 2 : (eax, ebx, ecx, edx, ebp, esi, edi : longint);
77 end;
78
79 Var
80 DosError : integer;
81
82 {Interrupt}
83 Procedure Intr(intno: byte; var regs: registers);
84 Procedure MSDos(var regs: registers);
85
86 {Info/Date/Time}
DosVersionnull87 Function DosVersion: Word;
88 Procedure GetDate(var year, month, mday, wday: word);
89 Procedure GetTime(var hour, minute, second, sec100: word);
90 Procedure UnpackTime(p: longint; var t: datetime);
91 Procedure PackTime(var t: datetime; var p: longint);
92
93 {Exec}
94 Procedure Exec(const path: pathstr; const comline: comstr);
DosExitCodenull95 Function DosExitCode: word;
96
97 {Disk}
DiskFreenull98 Function DiskFree(drive: byte) : int64;
DiskSizenull99 Function DiskSize(drive: byte) : int64;
100 Procedure FindFirst(const path: pathstr; attr: word; var f: searchRec);
101 Procedure FindNext(var f: searchRec);
102 Procedure FindClose(Var f: SearchRec);
103
104 {File}
105 Procedure GetFAttr(var f; var attr: word);
106 Procedure GetFTime(var f; var tim: longint);
FSearchnull107 Function FSearch(path: pathstr; dirlist: string): pathstr;
FExpandnull108 Function FExpand(const path: pathstr): pathstr;
109 Procedure FSplit(path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr);
110
111 {Environment}
EnvCountnull112 Function EnvCount: longint;
EnvStrnull113 Function EnvStr(index: integer): string;
GetEnvnull114 Function GetEnv(envvar: string): string;
115
116 {Misc}
117 Procedure SetFAttr(var f; attr: word);
118 Procedure SetFTime(var f; time: longint);
119 Procedure GetCBreak(var breakvalue: boolean);
120 Procedure SetCBreak(breakvalue: boolean);
121 Procedure GetVerify(var verify: boolean);
122 Procedure SetVerify(verify: boolean);
123
124 {Do Nothing Functions}
125 Procedure SwapVectors;
126 Procedure GetIntVec(intno: byte; var vector: pointer);
127 Procedure SetIntVec(intno: byte; vector: pointer);
128 Procedure Keep(exitcode: word);
129
130 implementation
131
uppernull132 function upper(const s : string) : string;
133 {
134 return uppercased string of s
135 }
136 var
137 i : longint;
138 begin
139 for i:=1 to length(s) do
140 if s[i] in ['a'..'z'] then
141 upper[i]:=char(byte(s[i])-32)
142 else
143 upper[i]:=s[i];
144 upper[0]:=s[0];
145 end;
146
147 {******************************************************************************
148 --- Conversion ---
149 ******************************************************************************}
150
151 {$ifdef MSWindows}
GetLastErrornull152 function GetLastError : DWORD;stdcall;
153 external 'Kernel32.dll' name 'GetLastError';
FileTimeToDosDateTimenull154 function FileTimeToDosDateTime(const ft :TFileTime;var data,time : word) : boolean;stdcall;
155 external 'Kernel32.dll' name 'FileTimeToDosDateTime';
DosDateTimeToFileTimenull156 function DosDateTimeToFileTime(date,time : word;var ft :TFileTime) : boolean;stdcall;
157 external 'Kernel32.dll' name 'DosDateTimeToFileTime';
FileTimeToLocalFileTimenull158 function FileTimeToLocalFileTime(const ft : TFileTime;var lft : TFileTime) : boolean;stdcall;
159 external 'Kernel32.dll' name 'FileTimeToLocalFileTime';
LocalFileTimeToFileTimenull160 function LocalFileTimeToFileTime(const lft : TFileTime;var ft : TFileTime) : boolean;stdcall;
161 external 'Kernel32.dll' name 'LocalFileTimeToFileTime';
162
163 type
164 Longrec=packed record
165 lo,hi : word;
166 end;
167
Last2DosErrornull168 function Last2DosError(d:dword):integer;
169 begin
170 Last2DosError:=d;
171 end;
172
173
DosToWinAttrnull174 Function DosToWinAttr (Const Attr : Longint) : longint;
175 begin
176 DosToWinAttr:=Attr;
177 end;
178
179
WinToDosAttrnull180 Function WinToDosAttr (Const Attr : Longint) : longint;
181 begin
182 WinToDosAttr:=Attr;
183 end;
184
185
DosToWinTimenull186 Function DosToWinTime (DTime:longint;Var Wtime : TFileTime):boolean;
187 var
188 lft : TFileTime;
189 begin
190 DosToWinTime:=DosDateTimeToFileTime(longrec(dtime).hi,longrec(dtime).lo,lft) and
191 LocalFileTimeToFileTime(lft,Wtime);
192 end;
193
194
WinToDosTimenull195 Function WinToDosTime (Const Wtime : TFileTime;var DTime:longint):boolean;
196 var
197 lft : TFileTime;
198 begin
199 WinToDosTime:=FileTimeToLocalFileTime(WTime,lft) and
200 FileTimeToDosDateTime(lft,longrec(dtime).hi,longrec(dtime).lo);
201 end;
202 {$endif}
203
204
205 {******************************************************************************
206 --- Dos Interrupt ---
207 ******************************************************************************}
208
209 procedure intr(intno : byte;var regs : registers);
210 begin
211 { !!!!!!!! }
212 end;
213
214 procedure msdos(var regs : registers);
215 begin
216 { !!!!!!!! }
217 end;
218
219
220 {******************************************************************************
221 --- Info / Date / Time ---
222 ******************************************************************************}
223
dosversionnull224 function dosversion : word;
225 begin
226 dosversion:=0;
227 end;
228
229
230 procedure getdate(var year,month,mday,wday : word);
231 begin
232 DecodeDate(Now,Year,Month,MDay);
233 WDay:=0;
234 // DecodeDateFully(Now,Year,Month,MDay,WDay);
235 end;
236
237
238 procedure gettime(var hour,minute,second,sec100 : word);
239 begin
240 DecodeTime(Now,Hour,Minute,Second,Sec100);
241 Sec100:=Sec100 div 10;
242 end;
243
244
245 Procedure packtime(var t : datetime;var p : longint);
246 Begin
247 p:=(t.sec shr 1)+(t.min shl 5)+(t.hour shl 11)+(t.day shl 16)+(t.month shl 21)+((t.year-1980) shl 25);
248 End;
249
250
251 Procedure unpacktime(p : longint;var t : datetime);
252 Begin
253 with t do
254 begin
255 sec:=(p and 31) shl 1;
256 min:=(p shr 5) and 63;
257 hour:=(p shr 11) and 31;
258 day:=(p shr 16) and 31;
259 month:=(p shr 21) and 15;
260 year:=(p shr 25)+1980;
261 end;
262 End;
263
264
265 {******************************************************************************
266 --- Exec ---
267 ******************************************************************************}
268 var
269 lastdosexitcode : word;
270
271 {$ifdef MSWindows}
272 procedure exec(const path : pathstr;const comline : comstr);
273 var
274 SI: TStartupInfo;
275 PI: TProcessInformation;
276 Proc : THandle;
277 l : DWord;
278 AppPath,
279 AppParam : array[0..255] of char;
280 begin
281 FillChar(SI, SizeOf(SI), 0);
282 SI.cb:=SizeOf(SI);
283 SI.wShowWindow:=1;
284 Move(Path[1],AppPath,length(Path));
285 AppPath[Length(Path)]:=#0;
286 AppParam[0]:='-';
287 AppParam[1]:=' ';
288 Move(ComLine[1],AppParam[2],length(Comline));
289 AppParam[Length(ComLine)+2]:=#0;
290 if not CreateProcess(PChar(@AppPath), PChar(@AppParam), Nil, Nil, False,$20, Nil, Nil, SI, PI) then
291 begin
292 DosError:=Last2DosError(GetLastError);
293 exit;
294 end
295 else
296 DosError:=0;
297 Proc:=PI.hProcess;
298 CloseHandle(PI.hThread);
299 if WaitForSingleObject(Proc, Infinite) <> $ffffffff then
300 GetExitCodeProcess(Proc,l)
301 else
302 l:=$ffffffff;
303 CloseHandle(Proc);
304 LastDosExitCode:=l;
305 end;
306 {$endif MSWindows}
307 {$ifdef Linux}
308 Procedure Exec (Const Path: PathStr; Const ComLine: ComStr);
309 var
310 pid,status : longint;
311 Begin
312 LastDosExitCode:=0;
313 pid:=Fork;
314 if pid=0 then
315 begin
316 {The child does the actual exec, and then exits}
317 Execl(@Path[1],@ComLine[1]);
318 {If the execve fails, we return an exitvalue of 127, to let it be known}
319 __exit(127);
320 end
321 else
322 if pid=-1 then {Fork failed}
323 begin
324 DosError:=8;
325 exit
326 end;
327 {We're in the parent, let's wait.}
328 WaitPid(Pid,@Status,0);
329 LastDosExitCode:=Status; // WaitPid and result-convert
330 if (LastDosExitCode>=0) and (LastDosExitCode<>127) then
331 DosError:=0
332 else
333 DosError:=8; // perhaps one time give an better error
334 End;
335 {$endif Linux}
336
dosexitcodenull337 function dosexitcode : word;
338 begin
339 dosexitcode:=lastdosexitcode;
340 end;
341
342
343 procedure swapvectors;
344 begin
345 end;
346
347
348 procedure getcbreak(var breakvalue : boolean);
349 begin
350 { !! No Win32 Function !! }
351 end;
352
353
354 procedure setcbreak(breakvalue : boolean);
355 begin
356 { !! No Win32 Function !! }
357 end;
358
359
360 procedure getverify(var verify : boolean);
361 begin
362 { !! No Win32 Function !! }
363 end;
364
365
366 procedure setverify(verify : boolean);
367 begin
368 { !! No Win32 Function !! }
369 end;
370
371
372 {******************************************************************************
373 --- Disk ---
374 ******************************************************************************}
375
376 {$ifdef Linux]
377 {
378 The Diskfree and Disksize functions need a file on the specified drive, since this
379 is required for the statfs system call.
380 These filenames are set in drivestr[0..26], and have been preset to :
381 0 - '.' (default drive - hence current dir is ok.)
382 1 - '/fd0/.' (floppy drive 1 - should be adapted to local system )
383 2 - '/fd1/.' (floppy drive 2 - should be adapted to local system )
384 3 - '/' (C: equivalent of dos is the root partition)
385 4..26 (can be set by you're own applications)
386 ! Use AddDisk() to Add new drives !
387 They both return -1 when a failure occurs.
388 }
389 Const
390 FixDriveStr : array[0..3] of pchar=(
391 '.',
392 '/fd0/.',
393 '/fd1/.',
394 '/.'
395 );
396 var
397 Drives : byte = 4;
398 var
399 DriveStr : array[4..26] of pchar;
400
401 Procedure AddDisk(const path:string);
402 begin
403 if not (DriveStr[Drives]=nil) then
404 FreeMem(DriveStr[Drives],StrLen(DriveStr[Drives])+1);
405 GetMem(DriveStr[Drives],length(Path)+1);
406 StrPCopy(DriveStr[Drives],path);
407 inc(Drives);
408 if Drives>26 then
409 Drives:=4;
410 end;
411
DiskFreenull412 Function DiskFree(Drive: Byte): int64;
413 var
414 fs : tstatfs;
415 Begin
416 if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and (statfs(fixdrivestr[drive],fs)=0)) or
417 ((not (drivestr[Drive]=nil)) and (statfs(drivestr[drive],fs)=0)) then
418 Diskfree:=int64(fs.f_bavail)*int64(fs.f_bsize)
419 else
420 Diskfree:=-1;
421 End;
422
DiskSizenull423 Function DiskSize(Drive: Byte): int64;
424 var
425 fs : tstatfs;
426 Begin
427 if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and (statfs(fixdrivestr[drive],fs)=0)) or
428 ((not (drivestr[Drive]=nil)) and (statfs(drivestr[drive],fs)=0)) then
429 Disksize:=int64(fs.f_blocks)*int64(fs.f_bsize)
430 else
431 Disksize:=-1;
432 End;
433
434 {$else linux}
435
diskfreenull436 function diskfree(drive : byte) : int64;
437 begin
438 DiskFree:=SysUtils.DiskFree(drive);
439 end;
440
441
disksizenull442 function disksize(drive : byte) : int64;
443 begin
444 DiskSize:=SysUtils.DiskSize(drive);
445 end;
446
447 {$endif linux}
448
449 {******************************************************************************
450 --- Findfirst FindNext ---
451 ******************************************************************************}
452
453 procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
454 begin
455 DosError:=SysUtils.FindFirst(Path,Attr,f);
456 end;
457
458
459 procedure findnext(var f : searchRec);
460 begin
461 DosError:=Sysutils.FindNext(f);
462 end;
463
464
465 Procedure FindClose(Var f: SearchRec);
466 begin
467 Sysutils.FindClose(f);
468 end;
469
470
471 {******************************************************************************
472 --- File ---
473 ******************************************************************************}
474
475 procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
476 var
477 p1,i : longint;
478 begin
479 { allow slash as backslash }
480 for i:=1 to length(path) do
481 if path[i]='/' then path[i]:='\';
482 { get drive name }
483 p1:=pos(':',path);
484 if p1>0 then
485 begin
486 dir:=path[1]+':';
487 delete(path,1,p1);
488 end
489 else
490 dir:='';
491 { split the path and the name, there are no more path informtions }
492 { if path contains no backslashes }
493 while true do
494 begin
495 p1:=pos('\',path);
496 if p1=0 then
497 break;
498 dir:=dir+copy(path,1,p1);
499 delete(path,1,p1);
500 end;
501 { try to find out a extension }
502 p1:=pos('.',path);
503 if p1>0 then
504 begin
505 ext:=copy(path,p1,4);
506 delete(path,p1,length(path)-p1+1);
507 end
508 else
509 ext:='';
510 name:=path;
511 end;
512
513
fexpandnull514 function fexpand(const path : pathstr) : pathstr;
515
516 var
517 s,pa : string[79];
518 i,j : longint;
519 begin
520 getdir(0,s);
521 pa:=upper(path);
522 { allow slash as backslash }
523 for i:=1 to length(pa) do
524 if pa[i]='/' then
525 pa[i]:='\';
526
527 if (length(pa)>1) and (pa[1] in ['A'..'Z']) and (pa[2]=':') then
528 begin
529 { we must get the right directory }
530 getdir(ord(pa[1])-ord('A')+1,s);
531 if (ord(pa[0])>2) and (pa[3]<>'\') then
532 if pa[1]=s[1] then
533 pa:=s+'\'+copy (pa,3,length(pa))
534 else
535 pa:=pa[1]+':\'+copy (pa,3,length(pa))
536 end
537 else
538 if pa[1]='\' then
539 pa:=s[1]+':'+pa
540 else if s[0]=#3 then
541 pa:=s+pa
542 else
543 pa:=s+'\'+pa;
544
545 { Turbo Pascal gives current dir on drive if only drive given as parameter! }
546 if length(pa) = 2 then
547 begin
548 getdir(byte(pa[1])-64,s);
549 pa := s;
550 end;
551
552 {First remove all references to '\.\'}
553 while pos ('\.\',pa)<>0 do
554 delete (pa,pos('\.\',pa),2);
555 {Now remove also all references to '\..\' + of course previous dirs..}
556 repeat
557 i:=pos('\..\',pa);
558 if i<>0 then
559 begin
560 j:=i-1;
561 while (j>1) and (pa[j]<>'\') do
562 dec (j);
563 if pa[j+1] = ':' then j := 3;
564 delete (pa,j,i-j+3);
565 end;
566 until i=0;
567
568 { Turbo Pascal gets rid of a \.. at the end of the path }
569 { Now remove also any reference to '\..' at end of line
570 + of course previous dir.. }
571 i:=pos('\..',pa);
572 if i<>0 then
573 begin
574 if i = length(pa) - 2 then
575 begin
576 j:=i-1;
577 while (j>1) and (pa[j]<>'\') do
578 dec (j);
579 delete (pa,j,i-j+3);
580 end;
581 pa := pa + '\';
582 end;
583 { Remove End . and \}
584 if (length(pa)>0) and (pa[length(pa)]='.') then
585 dec(byte(pa[0]));
586 { if only the drive + a '\' is left then the '\' should be left to prevtn the program
587 accessing the current directory on the drive rather than the root!}
588 { if the last char of path = '\' then leave it in as this is what TP does! }
589 if ((length(pa)>3) and (pa[length(pa)]='\')) and (path[length(path)] <> '\') then
590 dec(byte(pa[0]));
591 { if only a drive is given in path then there should be a '\' at the
592 end of the string given back }
593 if length(path) = 2 then pa := pa + '\';
594 fexpand:=pa;
595 end;
596
FSearchnull597 Function FSearch(path: pathstr; dirlist: string): pathstr;
598 var
599 i,p1 : longint;
600 s : searchrec;
601 newdir : pathstr;
602 begin
603 { No wildcards allowed in these things }
604 if (pos('?',path)<>0) or (pos('*',path)<>0) then
605 fsearch:=''
606 else
607 begin
608 { allow slash as backslash }
609 for i:=1 to length(dirlist) do
610 if dirlist[i]='/' then dirlist[i]:='\';
611 repeat
612 p1:=pos(';',dirlist);
613 if p1=0 then
614 begin
615 newdir:=copy(dirlist,1,p1-1);
616 delete(dirlist,1,p1);
617 end
618 else
619 begin
620 newdir:=dirlist;
621 dirlist:='';
622 end;
623 if (newdir<>'') and (not (newdir[length(newdir)] in ['\',':'])) then
624 newdir:=newdir+'\';
625 findfirst(newdir+path,anyfile,s);
626 if doserror=0 then
627 newdir:=newdir+path
628 else
629 newdir:='';
630 until (dirlist='') or (newdir<>'');
631 fsearch:=newdir;
632 end;
633 end;
634
635
636 procedure getftime(var f;var tim : longint);
637 begin
638 tim:=FileGetDate(filerec(f).handle);
639 end;
640
641
642 procedure setftime(var f;time : longint);
643 begin
644 {$ifdef linux}
645 FileSetDate(filerec(f).name,Time);
646 {$else}
647 FileSetDate(filerec(f).handle,Time);
648 {$endif}
649 end;
650
651
652 {$ifdef linux}
653 procedure getfattr(var f;var attr : word);
654 Var
655 info : tstatbuf;
656 LinAttr : longint;
657 Begin
658 DosError:=0;
659 if (FStat(filerec(f).handle,info)<>0) then
660 begin
661 Attr:=0;
662 DosError:=3;
663 exit;
664 end
665 else
666 LinAttr:=Info.st_Mode;
667 if S_ISDIR(LinAttr) then
668 Attr:=$10
669 else
670 Attr:=$20;
671 if Access(@filerec(f).name,W_OK)<>0 then
672 Attr:=Attr or $1;
673 if (not S_ISDIR(LinAttr)) and (filerec(f).name[0]='.') then
674 Attr:=Attr or $2;
675 end;
676 {$else}
677 procedure getfattr(var f;var attr : word);
678 var
679 l : longint;
680 begin
681 l:=FileGetAttr(filerec(f).name);
682 attr:=l;
683 end;
684 {$endif}
685
686
687 procedure setfattr(var f;attr : word);
688 begin
689 {$ifdef MSWindows}
690 FileSetAttr(filerec(f).name,attr);
691 {$endif}
692 end;
693
694
695 {******************************************************************************
696 --- Environment ---
697 ******************************************************************************}
698
699 {
700 The environment is a block of zero terminated strings
701 terminated by a #0
702 }
703
704 {$ifdef MSWindows}
GetEnvironmentStringsnull705 function GetEnvironmentStrings : pchar;stdcall;
706 external 'Kernel32.dll' name 'GetEnvironmentStringsA';
FreeEnvironmentStringsnull707 function FreeEnvironmentStrings(p : pchar) : boolean;stdcall;
708 external 'Kernel32.dll' name 'FreeEnvironmentStringsA';
709
envcountnull710 function envcount : longint;
711 var
712 hp,p : pchar;
713 count : longint;
714 begin
715 p:=GetEnvironmentStrings;
716 hp:=p;
717 count:=0;
718 while hp^<>#0 do
719 begin
720 { next string entry}
721 hp:=hp+strlen(hp)+1;
722 inc(count);
723 end;
724 FreeEnvironmentStrings(p);
725 envcount:=count;
726 end;
727
728
EnvStrnull729 Function EnvStr(index: integer): string;
730 var
731 hp,p : pchar;
732 count,i : longint;
733 begin
734 { envcount takes some time in win32 }
735 count:=envcount;
736
737 { range checking }
738 if (index<=0) or (index>count) then
739 begin
740 envstr:='';
741 exit;
742 end;
743 p:=GetEnvironmentStrings;
744 hp:=p;
745
746 { retrive the string with the given index }
747 for i:=2 to index do
748 hp:=hp+strlen(hp)+1;
749
750 envstr:=strpas(hp);
751 FreeEnvironmentStrings(p);
752 end;
753
754
GetEnvnull755 Function GetEnv(envvar: string): string;
756 var
757 s : string;
758 i : longint;
759 hp,p : pchar;
760 begin
761 getenv:='';
762 p:=GetEnvironmentStrings;
763 hp:=p;
764 while hp^<>#0 do
765 begin
766 s:=strpas(hp);
767 i:=pos('=',s);
768 if copy(s,1,i-1)=envvar then
769 begin
770 getenv:=copy(s,i+1,length(s)-i);
771 break;
772 end;
773 { next string entry}
774 hp:=hp+strlen(hp)+1;
775 end;
776 FreeEnvironmentStrings(p);
777 end;
778 {$else}
779
envcountnull780 function envcount : longint;
781 begin
782 envcount:=0;
783 end;
784
785
EnvStrnull786 Function EnvStr(index: integer): string;
787 begin
788 envstr:='';
789 end;
790
791
GetEnvnull792 Function GetEnv(envvar: string): string;
793 begin
794 getenv:=GetEnvironmentVariable(envvar);
795 end;
796
797 {$endif}
798
799
800 {******************************************************************************
801 --- Not Supported ---
802 ******************************************************************************}
803
804 Procedure keep(exitcode : word);
805 Begin
806 End;
807
808 Procedure getintvec(intno : byte;var vector : pointer);
809 Begin
810 End;
811
812 Procedure setintvec(intno : byte;vector : pointer);
813 Begin
814 End;
815
816
817 end.
818