fpc/rtl/os2/dos.pas

{****************************************************************************

						  FPKPascal Runtime-Library
						  Copyright (c) 1994,97 by
					Florian Klaempfl and Michael Spiegel
						 OS/2 port by Dani‰l Mantione

 ****************************************************************************}

{
  History:
  2.7.1994: Version 0.2
			Datenstrukturen sind deklariert sowie
			50 % der Unterprogramme sind implementiert
  12.8.1994: exec implemented
  14.8.1994: findfirst and findnext implemented
  24.8.1994: Version 0.3
  28.2.1995: Version 0.31
			 some parameter lists with const optimized
   3.7.1996: bug in fsplit removed (dir and ext were not intializised)
   7.7.1996: packtime and unpacktime implemented
  20.9.1996: Version 0.5
			 setftime and getftime implemented
			 some optimizations done (integer -> longint)
			 procedure fsearch from the LINUX version ported
			 msdos call implemented
  26th november 1996:
			 better fexpand
  29th january 1997:
			 bug in getftime and setftime removed
			 setfattr and getfattr added
   2th february 1997: Version 0.9
			 bug of searchrec corrected
   2 june 1997:
			 OS/2 support added.
   12 june 1997:
			 OS/2 port done.
}

unit dos;

{$I os.inc}

  interface

	uses
	   strings;

	const
	   { bit masks for CPU flags}
	   fcarry = $0001;
	   fparity = $0004;
	   fauxiliary = $0010;
	   fzero = $0040;
       fsign = $0080;
       foverflow  = $0800;

       { Bitmasken fuer Dateiattribute }
       readonly = $01;
       hidden = $02;
       sysfile = $04;
       volumeid = $08;
       directory = $10;
       archive = $20;
       anyfile = $3F;
       fmclosed = $D7B0;
       fminput = $D7B1;
       fmoutput = $D7B2;
       fminout = $D7B3;

    type
	   { some string types }
	   {$IFDEF OS2}
	   comstr=string; 				{Filenames can be long in OS/2.}
	   pathstr=string;
	   {$ELSE}
	   comstr = string[127];        { Kommandozeilenstring }
	   pathstr = string[79];        { String fuer einen Pfadnamen }
	   {$ENDIF}
	   dirstr = string[67];         { String fuer kompletten Pfad }
	   namestr = string[8];         { Dateinamenstring }
	   extstr = string[4];          { String fuer Dateinamensuffix }

	   { search record which is used by findfirst and findnext }
{$PACKRECORDS 1}
	   searchrec = record
		  fill : array[1..21] of byte;
		  attr : byte;
		  time : longint;
		  {$IFNDEF OS2}			{ A DJGPP strange thing.}
		  reserved : word; 		{ requires the DOS extender (DJ GNU-C) }
		  {$ENDIF}
		  size : longint;
		  {$IFNDEF OS2}
		  name : string[15]; 	{ the same size as declared by (DJ GNU C) }
		  {$ELSE}
		  name:string;			{Filenames can be very long in OS/2!}
		  {$ENDIF}
	   end;
{$PACKRECORDS 2}

       { file record for untyped files }
       filerec = record
          handle : word;
          mode : word;
		  recsize : word;
          _private : array[1..26] of byte;
          userdata: array[1..16] of byte;
          name: array[0..79] of char;
	   end;

       { file record for text files }
	   textbuf = array[0..127] of char;

       textrec = record
          handle : word;
          mode : word;
          bufSize : word;
          _private : word;
          bufpos : word;
          bufend : word;
          bufptr : ^textbuf;
          openfunc : pointer;
		  inoutfunc : pointer;
          flushfunc : pointer;
          closefunc : pointer;
          userdata : array[1..16] of byte;
		  name : array[0..79] of char;
		  buffer : textbuf;
       end;

       { data structure for the registers needed by msdos and intr }	
       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;

	   { record for date and time }
	   datetime = record
		  year,month,day,hour,min,sec : word;
	   end;

	{Flags for the exec procedure:

	 Starting the program:
	 efwait:		Wait until program terminates, otherwise the program
					continues execution.
	 efno_wait:		? Function unknown. Not implemented in EMX.
	 efoverlay:		Terminate this program, then execute the requested
					program. WARNING: Exit-procedures are not called!
	 efdebug:		Debug program. Details are unknown.
	 efsession:		Do not execute as child of this program. Use a seperate
					session instead.
	 efdetach:		Detached. Function unknown. Info wanted!
	 efpm:			Run as presentation manager program.

	 Determining the window state of the program:
	 efdefault:		Run the pm program in it's default situation.
	 efminimize:	Run the pm program minimized.
	 efmaximize:	Run the pm program maximized.
	 effullscreen:	Run the non-pm program fullscreen.
	 efwindowed:	Run the non-pm program in a window.

	 Other options are not implemented defined because lack of
	 knowledge abou what they do.}

	type	execrunflags=(efwait,efno_wait,efoverlay,efdebug,efsession,
						  efdetach,efpm);
			execwinflags=(efdefault,efminimize,efmaximize,effullscreen,
						  efwindowed);
			execset=set of execrunflags;

	var
	   { error variable }
	   doserror : integer;

	procedure getdate(var year,month,day,dayofweek : word);
	procedure gettime(var hour,minute,second,sec100 : word);
	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 findfirst(const path : pathstr;attr : word;var f : searchRec);
	procedure findnext(var f : searchRec);

	{ is a dummy }
	procedure swapvectors;

{   not supported:
	procedure getintvec(intno : byte;var vector : pointer);
	procedure setintvec(intno : byte;vector : pointer);
	procedure keep(exitcode : word);
}
	procedure msdos(var regs : registers);
	procedure intr(intno : byte;var regs : registers);

	procedure getfattr(var f;var attr : word);
	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);
	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);
	{$IFDEF OS2}
	function exec(path:pathstr;runflags:execset;winflags:execwinflags;
				  const comline:comstr):longint;
	{$ENDIF}
	function dosexitcode : word;
    function envcount : longint;
	function envstr(index : longint) : string;
	function getenv(const envvar : string): string;

  implementation

  {$ifdef OS2}

  type	OS2FSAllocate=record
			idfilesystem,
			csectorunit,
			cunit,
			cunitavail:longint;
			cbsector:word;
		end;

  function _DosQueryFSInfo(driveno:word;infolevel:word;
					  var info;infolen:word):word;[C];

  {$endif OS2}

	{ this was first written for the LINUX version,    }
	{ by Michael Van Canneyt but it works also         }
	{ for the DOS version (I hope so)                  }
	function fsearch(const path : pathstr;dirlist : string) : pathstr;

	  var
		 newdir : pathstr;
		 p1 : byte;
		 s : searchrec;

	  begin
		 if (pos('?',path)<>0) or (pos('*',path)<>0) then
		   { No wildcards allowed in these things }
		   fsearch:=''
		 else
		   begin
			  repeat
				{ get first path }
				p1:=pos(';',dirlist);
				if p1>0 then
				  begin
					 newdir:=copy(dirlist,1,p1-1);
					 delete(dirlist,1,p1)
				  end
				else
				  begin
					 newdir:=dirlist;
					 dirlist:=''
                  end;
                findfirst(newdir+'\'+path,anyfile,s);
                if doserror=0 then
                  begin
                     newdir:=newdir+'\'+s.name;
                     { this was for LINUX:
                     if pos('.\',newdir)=1 then
                       delete(newdir, 1, 2)
                     { DOS strips off an initial .\ }
					 }
				  end
				else newdir:='';
			  until(dirlist='') or (length(newdir)>0);
			  fsearch:=newdir;
		   end;
	  end;

	procedure getftime(var f;var time : longint);

	  begin
	{$IFNDEF OS2}
		 asm
			{ load handle }
			movl f,%ebx
			movw (%ebx),%bx
			{ get date }
			movw $0x5700,%ax
			int $0x21
			shll $16,%edx
			movw %cx,%dx
			movl time,%ebx
			movl %edx,(%ebx)
			xorb %ah,%ah
			movw %ax,U_DOS_DOSERROR
		 end;
	{$ELSE}
		 asm
			{ load handle }
			movl f,%ebx
			movw (%ebx),%bx
			{ get date }
			movw $0x5700,%ax
			call ___syscall
			shll $16,%edx
			movw %cx,%dx
			movl time,%ebx
			movl %edx,(%ebx)
			xorb %ah,%ah
			movw %ax,U_DOS_DOSERROR
		 end;
	{$ENDIF}
	  end;

   procedure setftime(var f;time : longint);

	  begin
	  {$IFNDEF OS2}
		 asm
			{ load handle }
			movl f,%ebx
			movw (%ebx),%bx
			movl time,%ecx
			shldl $16,%ecx,%edx
			{ set date }
			movw $0x5701,%ax
			int $0x21
			xorb %ah,%ah
			movw %ax,U_DOS_DOSERROR
		 end;
	  {$ELSE}
		 asm
			{ load handle }
			movl f,%ebx
			movw (%ebx),%bx
			movl time,%ecx
			shldl $16,%ecx,%edx
			{ set date }
			movw $0x5701,%ax
			call ___syscall
			xorb %ah,%ah
			movw %ax,U_DOS_DOSERROR
		 end;
	  {$ENDIF}
	  end;

	procedure msdos(var regs : registers);

	{ Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.}

	  begin
		 intr($21,regs);
	  end;

	procedure intr(intno : byte;var regs : registers);

	{ Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.}

	  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;

	var
	   lastdosexitcode : word;

	{$IFNDEF OS2}

	procedure exec(const path : pathstr;const comline : comstr);

	  procedure do_system(p : pchar);

		begin
		   asm
			  movl 12(%ebp),%ebx
			  movw $0xff07,%ax
			  int $0x21
			  movw %ax,_LASTDOSEXITCODE
		   end;
		end;

	  var
		 execute : string;
		 b : array[0..255] of char;

	  begin
		 execute:=path+' '+comline;
		 move(execute[1],b,length(execute));
		 b[length(execute)]:=#0;
		 do_system(b);
	  end;
	{$ELSE}

	procedure exec(const path:pathstr;const comline:comstr);

	{Execute a program.}

	begin
		exec(path,[efwait],efdefault,comline);
	end;

	function exec(path:pathstr;runflags:execset;winflags:execwinflags;
				  const comline:comstr):longint;

	{Execute a program. More suitable for OS/2 than the exec above.}

	{512 bytes should be enough to contain the command-line.}

	type	bytearray=array[0..8191] of byte;
			Pbytearray=^bytearray;
         { replaced by pbyte that works on smallset an normal set
			setarray=array[0..31] of byte; by (PM) }
         pbyte = ^byte;

			execstruc=record
				argofs,envofs,nameofs:pointer;
				argseg,envseg,nameseg:word;
				numarg,sizearg,
				numenv,sizeenv:word;
				mode1,mode2:byte;
			end;

	var	args:Pbytearray;
		env:Pbytearray;
		i,j:word;
		es:execstruc;
		esadr:pointer;

	begin
		getmem(args,512);
		getmem(env,8192);
		i:=1;
		j:=0;
		es.numarg:=0;
		while i<=length(comline) do
			begin
				if comline[i]<>' ' then
					begin
						{Commandline argument found. Copy it.}
						inc(es.numarg);
						args^[j]:=$80;
						inc(j);
						while (i<=length(comline)) and (comline[i]<>' ') do
							begin
								args^[j]:=byte(comline[i]);
								inc(j);
								inc(i);
							end;
						args^[j]:=0;
						inc(j);
					end;
				inc(i);
			end;
		args^[j]:=0;
		inc(j);

		{Commandline ready, now build the environment.

		 Oh boy, I always had the opinion that executing a program under Dos
		 was a hard job!}

		asm
			movl env,%edi		{Setup destination pointer.}
			movl _envc,%ecx		{Load number of arguments in edx.}
			movl _environ,%esi	{Load env. strings.}
			xorl %edx,%edx		{Count environment size.}
		exa1:
			lodsl				{Load a Pchar.}
			xchgl %eax,%ebx
		exa2:
			movb (%ebx),%al		{Load a byte.}
			incl %ebx			{Point to next byte.}
			stosb				{Store it.}
			incl %edx			{Increase counter.}
			cmpb $0,%al			{Ready ?.}
			jne exa2
			loop exa1			{Next argument.}
			stosb				{Store an extra 0 to finish. (AL is now 0).}
			incl %edx
			movl %edx,(24)es	{Store environment size.}
		end;

		{Environtment ready, now set-up exec structure.}
		es.argofs:=args;
		es.envofs:=env;
		asm
			leal path,%esi
			lodsb
			movzbl %al,%eax
			incl %eax
			addl %eax,%esi
			movb $0,(%esi)
		end;
		es.nameofs:=pointer(longint(@path)+1);
		asm
			movw %ss,(12)es		{Compiler doesn't like record elems in asm.}
			movw %ss,(14)es
			movw %ss,(16)es
		end;
		es.sizearg:=j;
		es.numenv:=0;
		{Typecasting of sets in FPK is a bit hard.}
      { this way works allways (PM) }
		es.mode1:=pbyte(@runflags)^;
		es.mode2:=byte(winflags);

		{Now exec the program.}
		esadr:=@es;
		asm
			movl esadr,%edx
			mov $0x7f06,%ax
			call ___syscall
			jnc exprg1
			movl %eax,U_DOS_DOSERROR
			xorl %eax,%eax
			decl %eax
		exprg1:
			movl %eax,__RESULT
		end;

		freemem(args,512);
		freemem(env,8192);
		{Phew! That's it. This was the most sophisticated procedure to call
		 a system function I ever wrote!}
	end;

	{$ENDIF}

	function dosexitcode : word;

	  begin
		 dosexitcode:=lastdosexitcode;
	  end;

	function dosversion : word;

	  begin
		{$IFNDEF OS2}
		 asm
			movb $0x30,%ah
			pushl %ebp
			int $0x21
			popl %ebp
			leave
			ret
		 end;
		{$ELSE}
		 {Returns DOS version in DOS and OS/2 version in OS/2}
		 asm
			movb $0x30,%ah
			call ___syscall
			leave
			ret
		 end;
		{$ENDIF}
	  end;

	procedure getdate(var year,month,day,dayofweek : word);

	  begin
		{$IFNDEF OS/2}
		 asm
			movb $0x2a,%ah
			pushl %ebp
			int $0x21
			popl %ebp
			xorb %ah,%ah
			movl 20(%ebp),%edi
			stosw
			movl 16(%ebp),%edi
			movb %dl,%al
			stosw
			movl 12(%ebp),%edi
			movb %dh,%al
			stosw
			movl 8(%ebp),%edi
			movw %cx,%ax
			stosw
		 end;
		{$ELSE}
		 asm
			movb $0x2a,%ah
			call ___syscall
			xorb %ah,%ah
			movl 20(%ebp),%edi
			stosw
			movl 16(%ebp),%edi
			movb %dl,%al
			stosw
			movl 12(%ebp),%edi
			movb %dh,%al
			stosw
			movl 8(%ebp),%edi
			xchgw %ecx,%eax
			stosw
		 end;
		{$ENDIF}
	  end;

	procedure setdate(year,month,day : word);

	  begin
		{$IFNDEF OS2}
		 asm
			movw 8(%ebp),%cx
			movb 10(%ebp),%dh
			movb 12(%ebp),%dl
			movb $0x2b,%ah
			pushl %ebp
			int $0x21
			popl %ebp
			xorb %ah,%ah
			movw %ax,U_DOS_DOSERROR
		 end;
		{$ELSE}
		{DOS only! You cannot change the system date in OS/2!}
		 asm
			movw 8(%ebp),%cx
			movb 10(%ebp),%dh
			movb 12(%ebp),%dl
			movb $0x2b,%ah
			call ___syscall
			xorb %ah,%ah
			movw %ax,U_DOS_DOSERROR
		 end;
		{$ENDIF}
	  end;

	procedure gettime(var hour,minute,second,sec100 : word);

	  begin
		{$IFNDEF OS2}
		 asm
			movb $0x2c,%ah
			pushl %ebp
			int $0x21
			popl %ebp
			xorb %ah,%ah
			movl 20(%ebp),%edi
			movb %dl,%al
			stosw
			movl 16(%ebp),%edi
			movb %dh,%al
			stosw
			movl 12(%ebp),%edi
			movb %cl,%al
			stosw
			movl 8(%ebp),%edi
			movb %ch,%al
			stosw
		 end;
		{$ELSE}
		 asm
			movb $0x2c,%ah
			call ___syscall
			xorb %ah,%ah
			movl 20(%ebp),%edi
			movb %dl,%al
			stosw
			movl 16(%ebp),%edi
			movb %dh,%al
			stosw
			movl 12(%ebp),%edi
			movb %cl,%al
			stosw
			movl 8(%ebp),%edi
			movb %ch,%al
			stosw
		 end;
		{$ENDIF}
	  end;

	procedure settime(hour,minute,second,sec100 : word);

	  begin
		{$IFNDEF OS2}
		 asm
			movb 8(%ebp),%ch
			movb 10(%ebp),%cl
			movb 12(%ebp),%dh
			movb 14(%ebp),%dl
			movb $0x2d,%ah
			pushl %ebp
			int $0x21
			popl %ebp
			xorb %ah,%ah
			movw %ax,U_DOS_DOSERROR
		 end;
		{$ELSE}
		 asm
			movb 8(%ebp),%ch
			movb 10(%ebp),%cl
			movb 12(%ebp),%dh
			movb 14(%ebp),%dl
			movb $0x2d,%ah
			call ___syscall
			xorb %ah,%ah
			movw %ax,U_DOS_DOSERROR
		 end;
		{$ENDIF}
	  end;

	procedure getcbreak(var breakvalue : boolean);

	  begin
		{$IFNDEF OS2}
		 asm
			movw $0x3300,%ax
			pushl %ebp
			int $0x21
			popl %ebp
			movl 8(%ebp),%eax
			movb %dl,(%eax)
		 end;
		{$ELSE}
		 {! Do not use in OS/2. Also not recommended in DOS. Use
			signal handling instead.}
		 asm
			movw $0x3300,%ax
			call ___syscall
			movl 8(%ebp),%eax
			movb %dl,(%eax)
		 end;
		{$ENDIF}
	  end;

	procedure setcbreak(breakvalue : boolean);

	  begin
		{$IFNDEF OS2}
		 asm
			movb 8(%ebp),%dl
			movl $0x3301,%ax
			pushl %ebp
			int $0x21
			popl %ebp
		 end;
		{$ELSE}
		 {! Do not use in OS/2. Also not recommended in DOS. Use
			signal handling instead.}
		 asm
			movb 8(%ebp),%dl
			movl $0x3301,%ax
			call ___syscall
		 end;
		{$ENDIF}
	  end;

	procedure getverify(var verify : boolean);

	  begin
		{$IFNDEF OS2}
		 asm
			movb $0x54,%ah
			pushl %ebp
			int $0x21
			popl %ebp
			movl 8(%ebp),%edi
			stosb
		 end;
		{$ELSE}
		 {! Do not use in OS/2.}
		 asm
			movb $0x54,%ah
			call ___syscall
			movl 8(%ebp),%edi
			stosb
		 end;
		{$ENDIF}
	  end;

	procedure setverify(verify : boolean);

	  begin
		{$IFNDEF OS2}
		 asm
			movb 8(%ebp),%al
			movl $0x2e,%ah
			pushl %ebp
			int $0x21
			popl %ebp
		 end;
		{$ELSE}
		 {! Do not use in OS/2.}
		 asm
			movb 8(%ebp),%al
			movl $0x2e,%ah
			call ___syscall
		 end;
		{$ENDIF}
	  end;

	function diskfree(drive : byte) : longint;

	var	fi:OS2FSallocate;

	begin
		{$IFNDEF OS2}
		asm
			movb 8(%ebp),%dl
			movb $0x36,%ah
			pushl %ebp
			int $0x21
			popl %ebp
			cmpw $-1,%ax
			je LDISKFREE1
			mulw %cx
			mulw %bx
			shll $16,%edx
			movw %ax,%dx
			movl %edx,%eax
			leave
			ret
		 LDISKFREE1:
			cwde
			leave
			ret
		end;
		{$ELSE}
		if os_mode=osDOS then
			{Function 36 is not supported in OS/2.}
			asm
				movb 8(%ebp),%dl
				movb $0x36,%ah
				call ___syscall
				cmpw $-1,%ax
				je LDISKFREE1
				mulw %cx
				mulw %bx
				shll $16,%edx
				movw %ax,%dx
				xchgl %edx,%eax
				leave
				ret
			 LDISKFREE1:
				cwde
				leave
				ret
			end
		 else
			{In OS/2, we use the filesystem information.}
			begin
				doserror:=_dosqueryFSinfo(drive,1,FI,sizeof(FI));
				if doserror=0 then
					diskfree:=FI.cunitavail*FI.csectorunit*FI.cbsector
				else
					diskfree:=-1;
			end;
		{$ENDIF}
	end;

	function disksize(drive : byte) : longint;

	begin
		{$IFNDEF OS/2}
		asm
			movb 8(%ebp),%dl
			movb $0x36,%ah
			pushl %ebp
			int $0x21
			popl %ebp
			movw %dx,%bx
			cmpw $-1,%ax
			je LDISKSIZE1
			mulw %cx
			mulw %bx
			shll $16,%edx
			movw %ax,%dx
			movl %edx,%eax
			leave
			ret
		 LDISKSIZE1:
			movl $-1,%eax
			leave
			ret
		end;
		{$ELSE}
		if os_mode=osDOS then
			{Function 36 is not supported in OS/2.}
			asm
				movb 8(%ebp),%dl
				movb $0x36,%ah
				call ___syscall
				movw %dx,%bx
				cmpw $-1,%ax
				je LDISKSIZE1
				mulw %cx
				mulw %bx
				shll $16,%edx
				movw %ax,%dx
				xchgl %edx,%eax
				leave
				ret
			 LDISKSIZE1:
				cwde
				leave
				ret
			 end;
		 else
			{In OS/2, we use the filesystem information.}
			begin
				doserror:=dosQFSinfo(drive,1,FI,sizeof(FI));
				if doserror=0 then
					diskfree:=FI.cunit*FI.csectorunit*FI.cbsector
				else
					diskfree:=-1;
			end;
		{$ENDIF}
	  end;

	procedure searchrec2dossearchrec(var f : searchrec);

	  var
		 l,i : longint;

	  {$IFDEF OS2}
	  const	namesize=255;
	  {$ELSE}
	  const	namesize=12;
	  {$ENDIF}

	  begin
		 l:=length(f.name);
		 for i:=1 to namesize do
		   f.name[i-1]:=f.name[i];
		 f.name[l]:=#0;
	  end;

	procedure dossearchrec2searchrec(var f : searchrec);

	  var
		 l,i : longint;

	  {$IFDEF OS2}
	  const	namesize=255;
	  {$ELSE}
	  const namesize=12;
	  {$ENDIF}

	  begin
		 for i:=0 to namesize do
		   if f.name[i]=#0 then
			 begin
				l:=i;
				break;
			 end;
		 for i:=namesize-1 downto 0 do
		   f.name[i+1]:=f.name[i];
		 f.name[0]:=chr(l);
	  end;

	procedure findfirst(const path : pathstr;attr : word;var f : searchRec);

	  procedure _findfirst(path : pchar;attr : word;var f : searchrec);

		begin
		   {$IFNDEF OS2}
		   asm
			  movl 18(%ebp),%edx
			  movb $0x1a,%ah
			  int $0x21
			  movl 12(%esp),%edx
			  movzwl 16(%esp),%ecx
			  movb $0x4e,%ah
			  int $0x21
			  jnc LFF
			  movw %ax,U_DOS_DOSERROR
		   LFF:
		   end;
		   {$ELSE}
		   asm
			  movl 12(%esp),%edx
			  movw 16(%esp),%cx
			  {No need to set DTA in EMX. Just give a pointer in ESI.}
			  movl 18(%ebp),%esi
			  movb $0x4e,%ah
			  call ___syscall
			  jnc LFF
			  movw %ax,U_DOS_DOSERROR
		   LFF:
		   end;
		   {$ENDIF}
		end;

	  var
		 path0 : array[0..80] of char;

	  begin
		 { no error }
		 doserror:=0;
		 strpcopy(path0,path);
		 _findfirst(path0,attr,f);
		 dossearchrec2searchrec(f);
	  end;

	procedure findnext(var f : searchRec);

	  procedure _findnext(var f : searchrec);

		begin
		   {$IFNDEF OS2}
		   asm
			  movl 12(%ebp),%edx
			  movb $0x1a,%ah
			  int $0x21
			  movb $0x4f,%ah
			  int $0x21
			  jnc LFN
			  movw %ax,U_DOS_DOSERROR
		   LFN:
		   end;
		   {$ELSE}
		   asm
			  movl 12(%ebp),%esi
			  movb $0x4f,%ah
			  call ___syscall
			  jnc LFN
			  movw %ax,U_DOS_DOSERROR
		   LFN:
		   end;
		   {$ENDIF}
		end;

	  begin
		 { no error }
		 doserror:=0;
		 searchrec2dossearchrec(f);
		 _findnext(f);
		 dossearchrec2searchrec(f);
	  end;

	procedure swapvectors;

	  begin
		 { tut nichts, DOS-Extender �bernimmt das N”tige }
		 { normalerweise selber                          }
		 { nur aus Kompatibilit„tsgr�nden implementiert  }
	  end;

	type
	   ppchar = ^pchar;

	function envs : ppchar;

	  begin
		 asm
			movl _environ,%eax
			leave
			ret
		 end ['EAX'];
	  end;

	function envcount : longint;

	  var
		 hp : ppchar;

	  begin
		{$IFNDEF OS2}
		 hp:=envs;
		 envcount:=0;
		 while assigned(hp^) do
		   begin
			  { not the best solution, but quite understandable }
			  inc(envcount);
			  hp:=hp+4;
		   end;
		{$ELSE}
			asm
				movl _envc,%eax
				leave
				ret
			end ['EAX'];
		{$ENDIF}
	  end;

	function envstr(index : longint) : string;

	  var
		 hp : ppchar;

	  begin
		 if (index<=0) or (index>envcount) then
		   begin
              envstr:='';
              exit;
           end;
		 hp:=envs+4*(index-1);
         envstr:=strpas(hp^);
	  end;

	function getenv(const envvar : string) : string;

      var
         hs,_envvar : string;
         eqpos,i : longint;

      begin
         _envvar:=upcase(envvar);
         getenv:='';
         for i:=1 to envcount do
           begin
              hs:=envstr(i);
              eqpos:=pos('=',hs);
			  if copy(hs,1,eqpos-1)=_envvar then
                begin
				   getenv:=copy(hs,eqpos+1,length(hs)-eqpos);
                   exit;
                end;
           end;
      end;

    procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;
      var ext : extstr);

      var
         p1 : byte;

      begin
         { try to find out a extension }
         p1:=pos('.',path);
         if p1>0 then
		   begin
              ext:=copy(path,p1,4);
              delete(path,p1,length(path)-p1+1);
           end
         else
           ext:='';
		 { get drive name }
         p1:=pos(':',path);
         if p1>0 then
           begin
			  dir:=path[1]+':';
              delete(path,1,p1);
           end
         else
           dir:='';
         { split the path and the name, there are no more path informtions }
         { if path contains no backslashes                                 }
         while true do
           begin
              p1:=pos('\',path);
              if p1=0 then
                break;
              dir:=dir+copy(path,1,p1);
              delete(path,1,p1);
           end;
         name:=path;
      end;

    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];

       begin
		  { There are differences between FPKPascal and Turbo Pascal
            e.g. for the string 'D:\DEMO\..\HELLO' which isn't handled }
          getdir(0,s);
          pa:=upcase(path);
          if (ord(pa[0])>1) and (((pa[1]>='A') and (pa[1]<='Z')) and (pa[2]=':')) then
            begin
               if (ord(pa[0])>2) and (pa[3]<>'\') then
                 if pa[1]=s[1] then
                   pa:=s+'\'+copy (pa,3,length(pa))
                 else
				   pa:=pa[1]+':\'+copy (pa,3,length(pa))
            end
          else
            if pa[1]='\' then 
              pa:=s[1]+':'+pa
            else if s[0]=#3 then
              pa:=s+pa
            else
              pa:=s+'\'+pa;
          fexpand:=pa;
       end;

     procedure packtime(var d : datetime;var time : longint);

       var
          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;

    procedure getfattr(var f;var attr : word);

      var
         { to avoid problems }
		 n : array[0..255] of char;
		 {$IFNDEF OS2}
		 r : registers;
		 {$ENDIF}

	  begin
		 strpcopy(n,filerec(f).name);
		{$IFNDEF OS2}
		 r.ax:=$4300;
		 r.edx:=longint(@n);
		 msdos(r);
		 attr:=r.cx;
		{$ELSE}
		 {Alas, msdos(r) doesn't work when we are running in OS/2.}
		 asm
			movw $0x4300,%ax
			leal n,%edx
			call ___syscall
			movl attr,%ebx
			movw %cx,(%ebx)
		 end;
		{$ENDIF}
	  end;

	procedure setfattr(var f;attr : word);

	  var
		 { to avoid problems }
		 n : array[0..255] of char;
		 {$IFNDEF OS2}
		 r : registers;
		 {$ENDIF}

	  begin
		 strpcopy(n,filerec(f).name);
		{$IFNDEF OS2}
		 r.ax:=$4301;
		 r.edx:=longint(@n);
		 r.cx:=attr;
		 msdos(r);
		{$ELSE}
		 {Alas, msdos(r) doesn't work when we are running in OS/2.}
		 asm
			movw $0x4301,%ax
			leal n,%edx
			movw attr,%cx
			call ___syscall
		 end;
		{$ENDIF}
	  end;
end.