Power-Programmierung/CD1.mdf/pascal/library/dos/nktools/dos4to5.pas

Pascal/Delphi Source File | 1990-06-18 | 19.1 KB | 456 lines

UNIT Dos4to5;
(*====================================================================*\
|| MODULE NAME:  Dos4to5                                              ||
|| DEPENDENCIES: System.TPU, Dos.TPU, StrUtil.TPU                     ||
|| LAST MOD ON:  8908.31                                              ||
|| PROGRAMMER:   Naoto Kimura                                         ||
||                                                                    ||
|| DESCRIPTION:  This is a library of DOS service routines for use    ||
||               with version 4.0 of the Turbo pascal compiler.  This ||
||               library of routines implements routines available in ||
||               version 5.0 of the Turbo pascal compiler that are    ||
||               unavailable in version 4.0.                          ||
||                                                                    ||
|| Modification history                                               ||
||                                                                    ||
|| 9006.18    Naoto Kimura                                            ||
||            * Recoded some of the routines in assembler for speed.  ||
\*====================================================================*)

{$S+}    {Stack checking on}
{$I-}    {I/O checking off}
{$N-}    {No numeric coprocessor}

INTERFACE

USES
    Dos,StrUtil;

(*--------------------------------------------------------------------*\
| NAME: DosVersion                                                     |
|                                                                      |
|     This function returns the version of DOS installed on the        |
| computer.  The low order byte of the word returned contains the      |
| major version number, while the high order byte contains the minor   |
| version number.                                                      |
\*--------------------------------------------------------------------*)
FUNCTION DosVersion : Word;

(*--------------------------------------------------------------------*\
| NAME: GetCBreak                                                      |
|                                                                      |
|     This procedure returns the Control-break checking status of DOS. |
\*--------------------------------------------------------------------*)
PROCEDURE GetCBreak (VAR Break : Boolean);

(*--------------------------------------------------------------------*\
| NAME: SetCBreak                                                      |
|                                                                      |
|     This procedure sets the Control-break checking status of DOS.    |
\*--------------------------------------------------------------------*)
PROCEDURE SetCBreak (Break : Boolean);

(*--------------------------------------------------------------------*\
| NAME: GetVerify                                                      |
|                                                                      |
|     This procedure sets the Control-break checking status of DOS.    |
\*--------------------------------------------------------------------*)
PROCEDURE GetVerify (var Verify : Boolean);

(*--------------------------------------------------------------------*\
| NAME: SetVerify                                                      |
|                                                                      |
|     This procedure sets the Control-break checking status of DOS.    |
\*--------------------------------------------------------------------*)
PROCEDURE SetVerify (Verify : Boolean);

TYPE
    ComStr    = string[127];
    PathStr    = string[79];
    DirStr    = string[67];
    NameStr    = string[8];
    ExtStr    = string[4];

(*--------------------------------------------------------------------*\
| NAME: FSearch                                                        |
|                                                                      |
|     This function is used to search for the specified file in a      |
| given set of directories.  The Path parameter is formatted in the    |
| same manner in which the DOS environment variable PATH is formatted  |
| (each entry is separated from the next with a semicolon).            |
\*--------------------------------------------------------------------*)
FUNCTION FSearch(
        Path    : PathStr;
        DirList    : String
    ) : PathStr;

(*--------------------------------------------------------------------*\
| NAME: FSplit                                                         |
|                                                                      |
|     This procedure splits a fully specified file name, and splits    |
| the filename into its components.                                    |
\*--------------------------------------------------------------------*)
PROCEDURE FSplit (
        Path    : PathStr;
    VAR Dir        : DirStr;
    VAR Name    : NameStr;
    VAR Ext        : ExtStr  );

(*--------------------------------------------------------------------*\
| NAME: FExpand                                                        |
|                                                                      |
|     This function expands the file name to a fully qualified path    |
| file name.                                                           |
\*--------------------------------------------------------------------*)
FUNCTION FExpand (
        Path : PathStr
    ) : PathStr;

(*--------------------------------------------------------------------*\
| NAME:  GetEnv                                                        |
|                                                                      |
|     This routine is patterned after the UNIX operating system call   |
| which obtains the value of a specified environment variable.  A      |
| process will inherit a copy of the parent's environment.  Often, the |
| environment variables are used to communicate between processes.     |
| Here are some examples of the usage of this function:                |
|                                                                      |
|     s := GetEnv('PATH'))          -- Sets "s" to the list of         |
|                                      directories in which executable |
|                                      programs are to be found.       |
|     writeln(GetEnv('PROMPT'))     -- Prints the value of the DOS     |
|                                      command interpreter prompt.     |
|     s := GetEnv('INITFILE')       -- Sets "s" to the value of the    |
|                                      environment variable "FOO".     |
\*--------------------------------------------------------------------*)
FUNCTION GetEnv( envvar : string ) : string;

(*--------------------------------------------------------------------*\
| NAME:  EnvCount                                                      |
|                                                                      |
|     This function returns the number of environment strings set in   |
| the environment.                                                     |
\*--------------------------------------------------------------------*)
FUNCTION EnvCount : integer;

(*--------------------------------------------------------------------*\
| NAME:  EnvStr                                                        |
|                                                                      |
|     This function returns the Index'th environment string.  The      |
| string returned by this function is of the form 'VAR=VALUE.'  If     |
| Index is beyond the last environment, then it will return a null     |
| string.                                                              |
\*--------------------------------------------------------------------*)
FUNCTION EnvStr( Index : integer ) : string;

IMPLEMENTATION

CONST
    DirSeparator    = '\';
    AltDirSeparator    = '/';
    DskSeparator    = ':';
    DirCharSet        : CharSet    = ['/','\'];
    DOSsepChars        : CharSet    = ['/','\',':'];

TYPE
    (*----------------------------------------------------------------*\
    | The following record type describes the contents of the Program  |
    | Segment Prefix (PSP).                                            |
    |                                                                  |
    |    int20H            exit code                              |
    |    TopOfMemory        Memory size in paragraphs              |
    |    Reserved0        ??? (0)                                |
    |    PSP_DOS        Far call to DOS                        |
    |    TerminationAddr    Terminate address                      |
    |    BreakExitAddr        Address of break handler               |
    |    CriticalErrorAddr    Address of critical error handler      |
    |    ParentPSP_Seg        Parent PSP segment                     |
    |    OpenFiles        Open files, $ff = unused               |
    |    EnvironmentSeg        Environment segment                    |
    |    PSP_OldStack        far pointer to processes SS:SP ???     |
    |    PSP_Nfiles        maximum open files                     |
    |    PSP_aofile        ofile address                          |
    |    Reserved3        Unused ???                             |
    |    PSP_int21        INT 21, far return                     |
    |    Reserved4        Unused ???                             |
    |    PSP_FCB1ext        FCB #1 extension                       |
    |    PSP_FCB1        FCB #1                                 |
    |    PSP_FCB2ext        FCB #2 extension                       |
    |    PSP_FCB2        FCB #2                                 |
    |    PSP_DMA        Command Tail                           |
    |                                                                  |
    \*----------------------------------------------------------------*)
    PSPtype    = RECORD
        int20H        : word;                {00}
        TopOfMemory        : word;                {02}
        Reserved0        : byte;                {04}
        PSP_DOS        : ARRAY [0..4] OF byte;        {05}
        TerminationAddr,                    {0A}
        BreakExitAddr,                    {0E}
        CriticalErrorAddr    : pointer;            {12}
        ParentPSP_Seg    : word;                {16}
        OpenFiles        : ARRAY [0..19] OF byte;    {18}
        EnvironmentSeg    : word;                {2C}
        PSP_OldStack    : pointer;            {2E}
        PSP_Nfiles        : integer;            {32}
        PSP_aofile        : pointer;            {34}
        Reserved3        : ARRAY [0..23] OF byte;    {38}
        PSP_int21        : ARRAY [0..1] OF byte;        {50}
        Reserved4        : ARRAY [0..1] OF byte;        {53}
        PSP_FCB1ext        : ARRAY [0..6] OF byte;        {55}
        PSP_FCB1        : ARRAY [0..8] OF byte;        {5C}
        PSP_FCB2ext        : ARRAY [0..6] OF byte;        {65}
        PSP_FCB2        : ARRAY [0..19] OF byte;    {6C}
        PSP_DMA        : ARRAY [0..127] OF byte    {80}
    END;

{$L Dos4to5.OBJ}

(*--------------------------------------------------------------------*\
| NAME: DosVersion                                                     |
\*--------------------------------------------------------------------*)
FUNCTION DosVersion : Word;
    External;

(*--------------------------------------------------------------------*\
| NAME: GetCBreak                                                      |
\*--------------------------------------------------------------------*)
PROCEDURE GetCBreak (VAR Break : Boolean);
    External;

(*--------------------------------------------------------------------*\
| NAME: SetCBreak                                                      |
\*--------------------------------------------------------------------*)
PROCEDURE SetCBreak (Break : Boolean);
    External;

(*--------------------------------------------------------------------*\
| NAME: GetVerify                                                      |
\*--------------------------------------------------------------------*)
PROCEDURE GetVerify (VAR Verify : Boolean);
    External;

(*--------------------------------------------------------------------*\
| NAME: SetVerify                                                      |
\*--------------------------------------------------------------------*)
PROCEDURE SetVerify (Verify : Boolean);
    External;

(*--------------------------------------------------------------------*\
| NAME: FSearch                                                        |
\*--------------------------------------------------------------------*)
FUNCTION FSearch(
        Path    : PathStr;
        DirList    : String
    ) : PathStr;
    VAR
    Found    : Boolean;
    Tmp    : String;
    i    : Integer;
    f    : Text;
    BEGIN
    Found := FALSE;
    Assign(f,Path);
    {$I-}Reset(f);{$I+}
    IF IOresult=0 THEN BEGIN
        Found := TRUE;
        Close(f);
        Tmp := Path
      END;
    WHILE (DirList <> '') AND NOT FOUND DO BEGIN
        i := Pos(';',DirList);
        IF i=0 THEN
        i := Length(DirList)+1;
        Tmp := Copy(DirList,1,i-1);
        DirList := Copy(DirList,i+1,Length(DirList)-i);
        IF Tmp[Length(Tmp)] IN ['/','\',':'] THEN
        Tmp := Tmp+Path
        ELSE
        Tmp := Tmp+'\'+Path;
        Assign(f,Tmp);
        {$I-}Reset(f);{$I+}
        IF IOresult=0 THEN BEGIN
        Found := TRUE;
        close(f)
          END
      END;
    IF Found THEN
        FSearch := Tmp
    ELSE
        FSearch := ''
    END;    (* FSearch *)

(*--------------------------------------------------------------------*\
| NAME: FSplit                                                         |
|                                                                      |
| EXTERNALS:                                                           |
|     const      DirSeparator, AltDirSeparator     (local to unit)     |
|     function   RCharSetPos                       (from StrUtil unit) |
\*--------------------------------------------------------------------*)
PROCEDURE FSplit (
        Path    : PathStr;
    VAR Dir        : DirStr;
    VAR Name    : NameStr;
    VAR Ext        : ExtStr  );
    VAR
    i,j    : integer;
    BEGIN
    i := RCharSetPos(DOSsepChars,Path);
    IF i=0 THEN
        Dir := ''
    ELSE BEGIN
        Dir := Copy(Path,1,i);
        Delete(Path,1,i)
      END;
    j := RPos('.',Path);
    IF j=0 THEN BEGIN
        Name := Path;
        Ext := ''
      END
    ELSE BEGIN
        Name := copy(Path,1,j-1);
        Ext := copy(Path,j,length(Path)-j+1)
      END
    END;    (* FSplit *)

(*--------------------------------------------------------------------*\
| NAME: FExpand                                                        |
|                                                                      |
| EXTERNALS:                                                           |
|     const      DirSeparator, AltDirSeparator     (local to unit)     |
|     function   RCharSetPos                       (from StrUtil unit) |
\*--------------------------------------------------------------------*)
FUNCTION FExpand (
        Path : PathStr
    ) : PathStr;
    VAR
    i,j        : integer;
    TmpStr,
    WorkBuffer    : string;
    BEGIN
    TmpStr := Path;
    (* strip off any drivespec and get pwd on drive *)
    IF Pos(DskSeparator,TmpStr) <> 2 THEN
        GetDir(0,WorkBuffer)
    ELSE IF NOT (Path[1] IN Alphabet) THEN
        GetDir(0,WorkBuffer)
    ELSE BEGIN
        GetDir(ord(UpCase(TmpStr[1]))-ord('A')+1, WorkBuffer);
        TmpStr := copy(TmpStr,3,length(TmpStr)-2)
      END;

    (* strip trailing slash on pwd of selected drive *)
    IF length(WorkBuffer) > 0 THEN
        IF WorkBuffer[length(WorkBuffer)] IN DirCharSet THEN
        Dec(WorkBuffer[0]);

    (* handle reference to root *)
    IF TmpStr[1] IN DirCharSet THEN BEGIN
        WorkBuffer[0] := #2;
        WHILE (length(TmpStr)>0) AND (TmpStr[1] IN DirCharSet) DO
        TmpStr := copy(TmpStr,2,length(TmpStr)-1)
      END;

    (* Strip relative refereces *)
    i := CharSetPos(DirCharSet,TmpStr);
    WHILE i <> 0 DO BEGIN
        IF copy(TmpStr,1,i-1)='.' THEN
        TmpStr := copy(TmpStr,3,length(TmpStr)-2)
        ELSE IF copy(TmpStr,1,i-1)='..' THEN BEGIN
        TmpStr := copy(TmpStr,4,length(TmpStr)-2);
        j := RCharSetPos(DirCharSet,WorkBuffer);
        IF j>0 THEN
            Dec(WorkBuffer[0],length(WorkBuffer)-j+1)
          END
        ELSE BEGIN
        WorkBuffer := WorkBuffer + DirSeparator
                + copy(TmpStr,1,i-1);
        TmpStr := copy(TmpStr,i+1,length(TmpStr)-i)
          END;
        i := CharSetPos(DirCharSet,TmpStr)
      END;
    IF TmpStr = '.' THEN
        FExpand := WorkBuffer
    ELSE IF TmpStr <> '..' THEN
        FExpand := WorkBuffer + DirSeparator + TmpStr
    ELSE BEGIN
        j := RCharSetPos(DirCharSet,WorkBuffer);
        IF j = 0 THEN
        FExpand := WorkBuffer + DirSeparator
        ELSE BEGIN
        IF j > 3 THEN
            Dec(WorkBuffer[0],length(WorkBuffer)-j+1)
        ELSE
            Dec(WorkBuffer[0],length(WorkBUffer)-j);
        FExpand := WorkBuffer
          END
      END
    END;    (* FExpand *)

CONST
    EnvironmentSeg    : word    = 0;

(*--------------------------------------------------------------------*\
| NAME:  GetEnv                                                        |
|                                                                      |
| EXTERNALS:                                                           |
|     word        EnvironmentSeg   (local to unit)                     |
\*--------------------------------------------------------------------*)
FUNCTION GetEnv( envvar : string ) : string;
    VAR
    i        : integer;
    found        : boolean;
    WorkBuffer    : string;
    BEGIN  (* GetEnv *)
    i := 0;
    found := false;
    WHILE NOT (found OR (mem[EnvironmentSeg:i]=0)) DO BEGIN
        WorkBuffer := '';
        WHILE mem[EnvironmentSeg:i] <> ord('=') DO BEGIN
        WorkBuffer := WorkBuffer + chr(mem[EnvironmentSeg:i]);
        Inc(i)
          END;
        Inc(i);        (* skip '=' *)
        found := WorkBuffer = envvar;
        WorkBuffer := '';
        WHILE mem[EnvironmentSeg:i] <> 0 DO BEGIN
        WorkBuffer := WorkBuffer + chr(mem[EnvironmentSeg:i]);
        Inc(i)
          END;
        Inc(i)        (* skip '\0' *)
      END;
    IF found THEN
        GetEnv := WorkBuffer
    ELSE
        GetEnv := ''
    END;  (* GetEnv *)

(*--------------------------------------------------------------------*\
| NAME:  EnvCount                                                      |
|                                                                      |
| EXTERNALS:                                                           |
|     word        EnvironmentSeg   (local to unit)                     |
\*--------------------------------------------------------------------*)
FUNCTION EnvCount : integer;
    External;

(*--------------------------------------------------------------------*\
| NAME:  EnvStr                                                        |
|                                                                      |
| EXTERNALS:                                                           |
|     word        EnvironmentSeg   (local to unit)                     |
\*--------------------------------------------------------------------*)
FUNCTION EnvStr( Index : integer ) : string;
    External;

(*====================================================================*\
||                  Dos4to5 unit initialization code                  ||
||--------------------------------------------------------------------||
|| EXTERNALS:                                                         ||
||     function  PrefixSeg                                            ||
||     type      PSPtype                                              ||
\*====================================================================*)
BEGIN
    EnvironmentSeg := PSPtype(ptr(PrefixSeg,$0)^).EnvironmentSeg
END.