mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-05 20:27:56 +02:00
+ first compiling and working version
This commit is contained in:
florian
parent
d92f56843e
commit
065d948961
700
rtl/win32/dos.pp
700
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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user