From 065d948961e5f632713a8031b62c2ad63c170268 Mon Sep 17 00:00:00 2001 From: florian Date: Sun, 26 Apr 1998 21:49:09 +0000 Subject: [PATCH] + first compiling and working version --- rtl/win32/dos.pp | 700 +++++++++-------------------------------------- 1 file changed, 123 insertions(+), 577 deletions(-) diff --git a/rtl/win32/dos.pp b/rtl/win32/dos.pp index f61ebc039b..8f9d8b45ee 100644 --- a/rtl/win32/dos.pp +++ b/rtl/win32/dos.pp @@ -23,14 +23,6 @@ unit dos; strings; const - { bit masks for CPU flags} - fcarry = $0001; - fparity = $0004; - fauxiliary = $0010; - fzero = $0040; - fsign = $0080; - foverflow = $0800; - { bit masks for file attributes } readonly = $01; hidden = $02; @@ -53,7 +45,6 @@ unit dos; extstr = string[4]; { string for an extension } { search record which is used by findfirst and findnext } -{$ifndef GO32V2} {$PACKRECORDS 1} searchrec = record fill : array[1..21] of byte; @@ -63,17 +54,7 @@ unit dos; size : longint; name : string[15]; { the same size as declared by (DJ GNU C) } end; -{$else GO32V2} -{$PACKRECORDS 1} - searchrec = record - fill : array[1..21] of byte; - attr : byte; - time : longint; - { reserved : word; not in DJGPP V2 } - size : longint; - name : string[12]; { the same size as declared by (DJ GNU C) } - end; -{$endif GO32V2} + {$PACKRECORDS 2} { file record for untyped files comes from filerec.inc} @@ -82,26 +63,6 @@ unit dos; { file record for text files comes from textrec.inc} {$i textrec.inc} -{$ifdef GO32V1} - { data structure for the registers needed by msdos and intr } - { Go32 V2 follows trealregs of go32 } - - registers = record - case i : integer of - 0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word); - 1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte); - 2 : (eax, ebx, ecx, edx, ebp, esi, edi : longint); - end; -{$endif GO32V1} - -{$ifdef GO32V2} - { data structure for the registers needed by msdos and intr } - { Go32 V2 follows trealregs of go32 } - - registers = go32.registers; - -{$endif GO32V2} - {$PACKRECORDS 1} { record for date and time } datetime = record @@ -117,16 +78,16 @@ unit dos; function dosversion : word; procedure setdate(year,month,day : word); procedure settime(hour,minute,second,sec100 : word); - procedure getcbreak(var breakvalue : boolean); - procedure setcbreak(breakvalue : boolean); - procedure getverify(var verify : boolean); - procedure setverify(verify : boolean); - function diskfree(drive : byte) : longint; - function disksize(drive : byte) : longint; +// procedure getcbreak(var breakvalue : boolean); +// procedure setcbreak(breakvalue : boolean); +// procedure getverify(var verify : boolean); +// procedure setverify(verify : boolean); +// function diskfree(drive : byte) : longint; +// function disksize(drive : byte) : longint; procedure findfirst(const path : pathstr;attr : word;var f : searchRec); procedure findnext(var f : searchRec); - { is a dummy in win32 } +// { is a dummy in win32 } procedure swapvectors; { not supported: @@ -141,14 +102,14 @@ unit dos; procedure setfattr(var f;attr : word); function fsearch(const path : pathstr;dirlist : string) : pathstr; - procedure getftime(var f;var time : longint); - procedure setftime(var f;time : longint); - procedure packtime (var d: datetime; var time: longint); - procedure unpacktime (time: longint; var d: datetime); +// procedure getftime(var f;var time : longint); +// procedure setftime(var f;time : longint); +// procedure packtime (var d: datetime; var time: longint); +// procedure unpacktime (time: longint; var d: datetime); function fexpand(const path : pathstr) : pathstr; procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr; var ext : extstr); - procedure exec(const path : pathstr;const comline : comstr); +// procedure exec(const path : pathstr;const comline : comstr); function dosexitcode : word; function envcount : longint; function envstr(index : longint) : string; @@ -156,6 +117,8 @@ unit dos; implementation +{$I win32.inc} + { taken from the DOS version } function fsearch(const path : pathstr;dirlist : string) : pathstr; @@ -212,245 +175,17 @@ unit dos; procedure getftime(var f;var time : longint); begin - dosregs.bx:=textrec(f).handle; - dosregs.ax:=$5700; - msdos(dosregs); - time:=(dosregs.dx shl 16)+dosregs.cx; - doserror:=dosregs.al; + {!!!!} end; procedure setftime(var f;time : longint); begin - dosregs.bx:=textrec(f).handle; - dosregs.ecx:=time; - dosregs.ax:=$5701; - msdos(dosregs); - doserror:=dosregs.al; + {!!!!} end; - procedure msdos(var regs : registers); - - begin - intr($21,regs); - end; -{$ifdef GO32V2} - procedure intr(intno : byte;var regs : registers); - - begin - realintr(intno,regs); - end; -{$else GO32V2} - procedure intr(intno : byte;var regs : registers); - - begin - asm - .data - int86: - .byte 0xcd - int86_vec: - .byte 0x03 - jmp int86_retjmp - - .text - movl 8(%ebp),%eax - movb %al,int86_vec - - movl 10(%ebp),%eax - // do not use first int - addl $2,%eax - - movl 4(%eax),%ebx - movl 8(%eax),%ecx - movl 12(%eax),%edx - movl 16(%eax),%ebp - movl 20(%eax),%esi - movl 24(%eax),%edi - movl (%eax),%eax - - jmp int86 - int86_retjmp: - pushf - pushl %ebp - pushl %eax - movl %esp,%ebp - // calc EBP new - addl $12,%ebp - movl 10(%ebp),%eax - // do not use first int - addl $2,%eax - - popl (%eax) - movl %ebx,4(%eax) - movl %ecx,8(%eax) - movl %edx,12(%eax) - // restore EBP - popl %edx - movl %edx,16(%eax) - movl %esi,20(%eax) - movl %edi,24(%eax) - // ignore ES and DS - popl %ebx /* flags */ - movl %ebx,32(%eax) - // FS and GS too - end; - end; -{$endif GO32V2} var lastdosexitcode : word; -{$ifdef GO32V2} - - { this code is just the most basic part of dosexec.c from - the djgpp code } - - procedure exec(const path : pathstr;const comline : comstr); - - procedure do_system(p,c : string); - - { - Table 0931 - Format of EXEC parameter block for AL=00h,01h,04h: - Offset Size Description - 00h WORD segment of environment to copy for child process (copy caller's - environment if 0000h) - this does not seem to work (PM) - 02h DWORD pointer to command tail to be copied into child's PSP - 06h DWORD pointer to first FCB to be copied into child's PSP - 0Ah DWORD pointer to second FCB to be copied into child's PSP - 0Eh DWORD (AL=01h) will hold subprogram's initial SS:SP on return - 12h DWORD (AL=01h) will hold entry point (CS:IP) on return - INT 21 4B-- - - Copied from Ralf Brown's Interrupt List - } - - type - realptr = record - ofs,seg : word; - end; - - texecblock = record - envseg : word; - comtail : realptr; - firstFCB : realptr; - secondFCB : realptr; - iniStack : realptr; - iniCSIP : realptr; - end; - - var current_dos_buffer_pos : longint; - function paste_to_dos(src : string) : boolean; - var c : array[0..255] of char; - begin - paste_to_dos:=false; - if current_dos_buffer_pos+length(src)+1>transfer_buffer+tb_size then - begin - doserror:=200;{ what value should we use here ? } - exit; - end; - move(src[1],c[0],length(src)); - c[length(src)]:=#0; - seg_move(get_ds,longint(@c),dosmemselector,current_dos_buffer_pos,length(src)+1); - current_dos_buffer_pos:=current_dos_buffer_pos+length(src)+1; - paste_to_dos:=true; - end; - var - i,la_env,la_p,la_c,la_e,fcb1_la,fcb2_la : longint; - arg_ofs : longint; - execblock : texecblock; - - begin - la_env:=transfer_buffer; - while (la_env mod 16)<>0 do inc(la_env); - current_dos_buffer_pos:=la_env; - for i:=1 to envcount do - begin - paste_to_dos(envstr(i)); - end; - paste_to_dos(''); { adds a double zero at the end } - { allow slash as backslash } - for i:=1 to length(p) do - if p[i]='/' then p[i]:='\'; - la_p:=current_dos_buffer_pos; - paste_to_dos(p); - la_c:=current_dos_buffer_pos; - paste_to_dos(c); - la_e:=current_dos_buffer_pos; - fcb1_la:=la_e; - la_e:=la_e+16; - fcb2_la:=la_e; - la_e:=la_e+16; - { allocate FCB see dosexec code } - dosregs.ax:=$2901; - arg_ofs:=1; - while (c[arg_ofs]=' ') or (c[arg_ofs]=#9) do inc(arg_ofs); - dosregs.ds:=(la_c+arg_ofs) div 16; - dosregs.si:=(la_c+arg_ofs) mod 16; - dosregs.es:=fcb1_la div 16; - dosregs.di:=fcb1_la mod 16; - msdos(dosregs); - repeat - inc(arg_ofs); - until (c[arg_ofs]=' ') or - (c[arg_ofs]=#9) or - (c[arg_ofs]=#13); - if c[arg_ofs]<>#13 then - begin - inc(arg_ofs); - while (c[arg_ofs]=' ') or (c[arg_ofs]=#9) do inc(arg_ofs); - end; - { allocate second FCB see dosexec code } - dosregs.ax:=$2901; - dosregs.ds:=(la_c+arg_ofs) div 16; - dosregs.si:=(la_c+arg_ofs) mod 16; - dosregs.es:=fcb2_la div 16; - dosregs.di:=fcb2_la mod 16; - msdos(dosregs); - with execblock do - begin - envseg:=la_env div 16; - comtail.seg:=la_c div 16; - comtail.ofs:=la_c mod 16; - firstFCB.seg:=fcb1_la div 16; - firstFCB.ofs:=fcb1_la mod 16; - secondFCB.seg:=fcb2_la div 16; - secondFCB.ofs:=fcb2_la mod 16; - end; - seg_move(get_ds,longint(@execblock),dosmemselector,la_e,sizeof(texecblock)); - dosregs.edx:=la_p mod 16; - dosregs.ds:=la_p div 16; - dosregs.ebx:=la_e mod 16; - dosregs.es:=la_e div 16; - dosregs.ax:=$4b00; - msdos(dosregs); - if (dosregs.flags and 1) <> 0 then - begin - doserror:=dosregs.ax; - lastdosexitcode:=0; - exit; - end - else - begin - dosregs.ax:=$4d00; - msdos(dosregs); - lastdosexitcode:=dosregs.al; - end; - end; - - { var - p,c : array[0..255] of char; } - var c : string; - begin - doserror:=0; - { move(path[1],p,length(path)); - p[length(path)]:=#0; } - move(comline[0],c[1],length(comline)+1); - c[length(comline)+2]:=#13; - c[0]:=char(length(comline)+2); - do_system(path,c); - end; - -{$else GO32V2} procedure exec(const path : pathstr;const comline : comstr); @@ -480,8 +215,6 @@ unit dos; do_system(b); end; -{$endif GO32V2} - function dosexitcode : word; begin @@ -491,115 +224,104 @@ unit dos; function dosversion : word; begin - dosregs.ax:=$3000; - msdos(dosregs); - dosversion:=dosregs.ax; + dosversion:=lo(getversion); end; procedure getdate(var year,month,day,dayofweek : word); + var + t : SYSTEMTIME; + begin - dosregs.ax:=$2a00; - msdos(dosregs); - dayofweek:=dosregs.al; - year:=dosregs.cx; - month:=dosregs.dh; - day:=dosregs.dl; + GetLocalTime(t); + year:=t.wYear; + month:=t.wMonth; + day:=t.wDay; + dayofweek:=t.wDayOfWeek; end; procedure setdate(year,month,day : word); + var + t : SYSTEMTIME; + begin - dosregs.cx:=year; - dosregs.dx:=month*$100+day; - dosregs.ah:=$2b; - msdos(dosregs); - doserror:=dosregs.al; + { we need the time set privilege } + { so this function crash currently } + {!!!!!} + GetLocalTime(t); + t.wYear:=year; + t.wMonth:=month; + t.wDay:=day; + { only a quite good solution, we can loose some ms } + SetLocalTime(t); end; procedure gettime(var hour,minute,second,sec100 : word); + var + t : SYSTEMTIME; + begin - dosregs.ah:=$2c; - msdos(dosregs); - hour:=dosregs.ch; - minute:=dosregs.cl; - second:=dosregs.dh; - sec100:=dosregs.dl; + GetLocalTime(t); + hour:=t.wHour; + minute:=t.wMinute; + second:=t.wSecond; + sec100:=t.wMilliSeconds div 10; end; procedure settime(hour,minute,second,sec100 : word); + var + t : SYSTEMTIME; + begin - dosregs.cx:=hour*$100+minute; - dosregs.dx:=second*$100+sec100; - dosregs.ah:=$2d; - msdos(dosregs); - doserror:=dosregs.al; + { we need the time set privilege } + { so this function crash currently } + {!!!!!} + + GetLocalTime(t); + t.wHour:=hour; + t.wMinute:=minute; + t.wSecond:=second; + t.wMilliSeconds:=sec100*10; + SetLocalTime(t); end; procedure getcbreak(var breakvalue : boolean); begin - dosregs.ax:=$3300; - msdos(dosregs); - breakvalue:=dosregs.dl<>0; + {!!!!} end; procedure setcbreak(breakvalue : boolean); begin - dosregs.ax:=$3301; - dosregs.dl:=ord(breakvalue); - msdos(dosregs); + {!!!!} end; procedure getverify(var verify : boolean); begin - dosregs.ah:=$54; - msdos(dosregs); - verify:=dosregs.al<>0; + {!!!!} end; procedure setverify(verify : boolean); begin - dosregs.ah:=$2e; - dosregs.al:=ord(verify); - msdos(dosregs); + {!!!!} end; function diskfree(drive : byte) : longint; begin - dosregs.dl:=drive; - dosregs.ah:=$36; - msdos(dosregs); - if dosregs.ax<>$FFFF then - begin - diskfree:=dosregs.ax; - diskfree:=diskfree*dosregs.bx; - diskfree:=diskfree*dosregs.cx; - end - else - diskfree:=-1; + {!!!!} end; function disksize(drive : byte) : longint; begin - dosregs.dl:=drive; - dosregs.ah:=$36; - msdos(dosregs); - if dosregs.ax<>$FFFF then - begin - disksize:=dosregs.ax; - disksize:=disksize*dosregs.cx; - disksize:=disksize*dosregs.dx; - end - else - disksize:=-1; + {!!!!} end; procedure searchrec2dossearchrec(var f : searchrec); @@ -634,8 +356,6 @@ unit dos; procedure findfirst(const path : pathstr;attr : word;var f : searchRec); -{$ifdef GO32V2} - procedure _findfirst(path : pchar;attr : word;var f : searchrec); var @@ -644,49 +364,9 @@ unit dos; { allow slash as backslash } for i:=0 to strlen(path) do if path[i]='/' then path[i]:='\'; - copytodos(f,sizeof(searchrec)); - dosregs.edx:=transfer_buffer mod 16; - dosregs.ds:=transfer_buffer div 16; - dosregs.ah:=$1a; - msdos(dosregs); - dosregs.ecx:=attr; - dosregs.edx:=(transfer_buffer mod 16) + Sizeof(searchrec)+1; - dosmemput(transfer_buffer div 16, - (transfer_buffer mod 16) +Sizeof(searchrec)+1,path^,strlen(path)+1); - dosregs.ds:=transfer_buffer div 16; - dosregs.ah:=$4e; - msdos(dosregs); - copyfromdos(f,sizeof(searchrec)); - if dosregs.flags and carryflag<>0 then - doserror:=dosregs.ax; + {!!!!!!!} end; -{$else GO32V2} - - procedure _findfirst(path : pchar;attr : word;var f : searchrec); - - var - i : longint; - begin - { allow slash as backslash } - for i:=0 to strlen(path) do - if path[i]='/' then path[i]:='\'; - asm - movl 18(%ebp),%edx - movb $0x1a,%ah - int $0x21 - movl 12(%ebp),%edx - movzwl 16(%ebp),%ecx - movb $0x4e,%ah - int $0x21 - jnc .LFF - movw %ax,U_DOS_DOSERROR - .LFF: - end; - end; - -{$endif GO32V2} - var path0 : array[0..80] of char; @@ -700,42 +380,12 @@ unit dos; procedure findnext(var f : searchRec); -{$ifdef GO32V2} - procedure _findnext(var f : searchrec); begin - copytodos(f,sizeof(searchrec)); - dosregs.edx:=transfer_buffer mod 16; - dosregs.ds:=transfer_buffer div 16; - dosregs.ah:=$1a; - msdos(dosregs); - dosregs.ah:=$4f; - msdos(dosregs); - copyfromdos(f,sizeof(searchrec)); - if dosregs.flags and carryflag <> 0 then - doserror:=dosregs.ax; + {!!!!} end; -{$else GO32V2} - - procedure _findnext(var f : searchrec); - - begin - asm - movl 12(%ebp),%edx - movb $0x1a,%ah - int $0x21 - movb $0x4f,%ah - int $0x21 - jnc .LFN - movw %ax,U_DOS_DOSERROR - .LFN: - end; - end; - -{$endif GO32V2} - begin { no error } doserror:=0; @@ -746,108 +396,82 @@ unit dos; procedure swapvectors; -{$ifdef go32v2} -{ uses four global symbols from v2prt0.as - to be able to know the current exception state - without using dpmiexcp unit } - begin - asm - movl _exception_exit,%eax - orl %eax,%eax - je .Lno_excep - movl _v2prt0_exceptions_on,%eax - orl %eax,%eax - je .Lexceptions_off - movl _swap_out,%eax - call *%eax - jmp .Lno_excep - .Lexceptions_off: - movl _swap_in,%eax - call *%eax - .Lno_excep: - end; - end; -{$else not go32v2} begin { only a dummy } end; -{$endif go32v2} - - type - ppchar = ^pchar; - -{$ifdef GO32V1} - - function envs : ppchar; - - begin - asm - movl _environ,%eax - leave - ret - end ['EAX']; - end; - -{$endif} + { the environment is a block of zero terminated strings } + { terminated by a #0 } function envcount : longint; var - hp : ppchar; + hp,p : pchar; begin -{$ifdef GO32V2} - hp:=environ; -{$else GO32V2} - hp:=envs; -{$endif} + p:=GetEnvironmentStrings; + hp:=p; envcount:=0; - while assigned(hp^) do + while hp^<>#0 do begin - { not the best solution, but quite understandable } + { next string entry} + hp:=hp+strlen(hp)+1; inc(envcount); - hp:=hp+4; end; + FreeEnvironmentStrings(p); end; function envstr(index : longint) : string; var - hp : ppchar; + hp,p : pchar; + count,i : longint; + begin - if (index<=0) or (index>envcount) then + { envcount takes some time in win32 } + count:=envcount; + + { range checking } + if (index<=0) or (index>count) then begin envstr:=''; exit; end; -{$ifdef GO32V2} - hp:=environ+4*(index-1); -{$else GO32V2} - hp:=envs+4*(index-1); -{$endif GO32V2} - envstr:=strpas(hp^); + p:=GetEnvironmentStrings; + hp:=p; + + { retrive the string with the given index } + for i:=2 to index do + hp:=hp+strlen(hp)+1; + + envstr:=strpas(hp); + FreeEnvironmentStrings(p); end; function getenv(const envvar : string) : string; var - hs,_envvar : string; - eqpos,i : longint; + s : string; + i : longint; + hp,p : pchar; begin - _envvar:=upcase(envvar); getenv:=''; - for i:=1 to envcount do + p:=GetEnvironmentStrings; + hp:=p; + while hp^<>#0 do begin - hs:=envstr(i); - eqpos:=pos('=',hs); - if copy(hs,1,eqpos-1)=_envvar then + s:=strpas(hp); + i:=pos('=',s); + if copy(s,1,i-1)=envvar then begin - getenv:=copy(hs,eqpos+1,length(hs)-eqpos); - exit; + getenv:=copy(s,i+1,length(s)-i); + break; end; + { next string entry} + hp:=hp+strlen(hp)+1; end; + FreeEnvironmentStrings(p); end; procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr; @@ -893,23 +517,12 @@ unit dos; function fexpand(const path : pathstr) : pathstr; - function get_current_drive : byte; - - var - r : registers; - - begin - r.ah:=$19; - msdos(r); - get_current_drive:=r.al; - end; - var s,pa : string[79]; i,j : byte; begin - { There are differences between FPKPascal and Turbo Pascal + { There are differences between Free Pascal and Turbo Pascal e.g. for the string 'D:\DEMO\..\HELLO' which isn't handled } getdir(0,s); pa:=upcase(path); @@ -958,111 +571,44 @@ unit dos; zs : longint; begin - time:=-1980; - time:=time+d.year and 127; - time:=time shl 4; - time:=time+d.month; - time:=time shl 5; - time:=time+d.day; - time:=time shl 16; - zs:=d.hour; - zs:=zs shl 6; - zs:=zs+d.min; - zs:=zs shl 5; - zs:=zs+d.sec div 2; - time:=time+(zs and $ffff); + {!!!!} end; procedure unpacktime (time: longint; var d: datetime); begin - d.sec:=(time and 31) * 2; - time:=time shr 5; - d.min:=time and 63; - time:=time shr 6; - d.hour:=time and 31; - time:=time shr 5; - d.day:=time and 31; - time:=time shr 5; - d.month:=time and 15; - time:=time shr 4; - d.year:=time + 1980; + {!!!!} end; -{$ifdef GO32V2} - procedure getfattr(var f;var attr : word); var - r : registers; + l : longint; begin - copytodos(filerec(f).name,strlen(filerec(f).name)+1); - r.ax:=$4300; - r.edx:=transfer_buffer mod 16; - r.ds:=transfer_buffer div 16; - msdos(r); - if (r.flags and carryflag) <> 0 then - doserror:=r.ax; - attr:=r.cx; + l:=GetFileAttributes(filerec(f).name); + if l=$ffffffff then + doserror:=getlasterror; + attr:=l; end; procedure setfattr(var f;attr : word); - var - r : registers; - begin - copytodos(filerec(f).name,strlen(filerec(f).name)+1); - r.ax:=$4301; - r.edx:=transfer_buffer mod 16; - r.ds:=transfer_buffer div 16; - r.cx:=attr; - msdos(r); - if (r.flags and carryflag) <> 0 then - doserror:=r.ax; + doserror:=0; + if not(SetFileAttributes(filerec(f).name,attr)) then + doserror:=getlasterror; end; -{$else GO32V2} - - procedure getfattr(var f;var attr : word); - - var - { to avoid problems } - n : array[0..255] of char; - r : registers; - - begin - strpcopy(n,filerec(f).name); - r.ax:=$4300; - r.edx:=longint(@n); - msdos(r); - attr:=r.cx; - end; - - procedure setfattr(var f;attr : word); - - var - { to avoid problems } - n : array[0..255] of char; - r : registers; - - begin - strpcopy(n,filerec(f).name); - r.ax:=$4301; - r.edx:=longint(@n); - r.cx:=attr; - msdos(r); - end; - -{$endif GO32V2} - end. { $Log$ - Revision 1.1 1998-03-25 11:18:47 root - Initial revision + Revision 1.2 1998-04-26 21:49:09 florian + + first compiling and working version + + Revision 1.1.1.1 1998/03/25 11:18:47 root + * Restored version Revision 1.2 1998/03/10 13:23:56 florian * just a few things adapted to win32