home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / TP002.ZIP / FORK.INC < prev    next >
Encoding:
Text File  |  1986-05-31  |  4.6 KB  |  196 lines
  1.  
  2. { File FORK.INC }
  3.  
  4. CONST
  5.   CR       = ^M;
  6.   Null     = ^@;
  7.  
  8. TYPE
  9.   AnyString = String[255];
  10.  
  11. VAR
  12.   EnvSegAbs  : Integer ABSOLUTE CSeg:$002c; {environment string segment}
  13.  
  14. FUNCTION DOSErrorMsg(AX : Integer) : Anystring;
  15.  
  16. VAR
  17.   ErrNumStr : AnyString;
  18.  
  19. BEGIN   { DOSErrorMsg }
  20.  
  21. CASE AX of
  22.   1  : DOSErrorMsg := 'Invalid function';
  23.   2  : DOSErrorMsg := 'File not found';
  24.   3  : DOSErrorMsg := 'Path not found';
  25.   4  : DOSErrorMsg := 'Too many file names';
  26.   5  : DOSErrorMsg := 'Access denied';
  27.   7  : DOSErrorMsg := 'Arena trashed';
  28.   8  : DOSErrorMsg := 'Not enough memory';
  29.   9  : DOSErrorMsg := 'Invalid block';
  30.   10 : DOSErrorMsg := 'Bad environment';
  31.   11 : DOSErrorMsg := 'Bad format';
  32.  
  33.   ELSE
  34.     Begin
  35.       Str(AX, ErrNumStr);
  36.       DOSErrorMsg := 'DOS Error ' + ErrNumStr;
  37.     End;
  38.   END;   {CASE}
  39.  
  40. END;     {FUNCTION DOSErrorMsg }
  41.  
  42.  
  43. FUNCTION Fork (ProgName, Cmdline : AnyString ) : Boolean;
  44.  
  45. TYPE
  46.   RegType = RECORD
  47.               AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags : Integer;
  48.             END;
  49.  
  50.   FCBType = Array[0..36] of Char;
  51.  
  52. VAR
  53.   Regs         : RegType;
  54.   Status       : Boolean;
  55.   CmdLen       : Byte ABSOLUTE CmdLine;
  56.   FCB1, FCB2   : FCBType;
  57.   ParmBlock    : Record
  58.                    EnvSeg     : Integer;
  59.                    CmdPtr     : ^AnyString;
  60.                    FCB1Ptr    : ^FCBType;
  61.                    FCB2Ptr    : ^FCBType;
  62.                  End;
  63.  
  64. FUNCTION CallDOS (VAR Regs : RegType) : Boolean;
  65.  
  66. Begin    { Function CallDOS }
  67.  
  68.   MsDos(Regs);
  69.   CallDOS := (NOT Odd(Regs.Flags));
  70.  
  71. End;     { Function CallDOS }
  72.  
  73. PROCEDURE MakeFCB(CmdLine : AnyString; VAR FCB1, FCB2 : FCBType);
  74.  
  75. VAR
  76.   Regs        : RegType;
  77.   DummyFlag   : Boolean;
  78.  
  79. Begin        { Procedure MakeFCB }
  80.  
  81.   FillChar( FCB1, SizeOf(FCB1), 0 );
  82.   Regs.AX      := $2901;
  83.   Regs.DS      := Seg(CmdLine[1]);
  84.   Regs.SI      := Ofs(CmdLine[1]);
  85.   Regs.ES      := Seg(FCB1);
  86.   Regs.DI      := Ofs(FCB1);
  87.   DummyFlag    := CallDOS(Regs);
  88.  
  89.   FillChar( FCB2, SizeOf(FCB2), 0 );
  90.   Regs.AX      := $2901;
  91.   Regs.ES      := Seg(FCB2);
  92.   Regs.DI      := Ofs(FCB2);
  93.   DummyFlag    := CallDOS(Regs);
  94.  
  95. End;        {Procedure MakeFCB }
  96.  
  97.  
  98. BEGIN       { FUNCTION Fork }
  99.  
  100. Status := TRUE;
  101.  
  102.   MakeFCB( CmdLine, FCB1, FCB2 );
  103.   ProgName   := ProgName + Null;
  104.   CmdLine    := ' ' + Cmdline + CR;
  105.   CmdLen     := Pred(CmdLen);
  106.   WITH ParmBlock DO
  107.     Begin
  108.       EnvSeg     := EnvSegAbs;
  109.       CmdPtr     := Addr(CmdLine);
  110.       FCB1Ptr    := Addr(FCB1);
  111.       FCB2Ptr    := Addr(FCB2);
  112.     End;
  113.  
  114.   Regs.AX   := $4b00;
  115.   Regs.BX   := Ofs(ParmBlock);
  116.   Regs.DX   := Ofs(ProgName[1]);
  117.   Regs.DS   := Seg(ProgName[1]);
  118.   Regs.ES   := Seg(ParmBlock);
  119.  
  120.   If (NOT CallDOS(Regs)) Then
  121.     Begin
  122.       Status := FALSE;
  123.       Writeln('Unable to run "', ProgName,'" with "', CmdLine,'" : ',
  124.             DOSErrorMsg(Regs.AX));
  125.     End;
  126.  
  127. Fork := Status;
  128.  
  129. END;        { Function Fork }
  130.  
  131. { *********************************************************************** }
  132.  
  133. Function System( AnyCommand : AnyString ) : Boolean;
  134.  
  135. VAR
  136.   CommandInt : AnyString;
  137.  
  138. Function GetEnv( SearchName : AnyString ) : AnyString;
  139.  
  140. TYPE
  141.   EnvArrType = Array[0..32767] of Char;
  142.  
  143. VAR
  144.   EnvArrPtr    : ^EnvArrType;
  145.   Index        : Integer;
  146.   FoundName    : AnyString;
  147.   FoundValue   : AnyString;
  148.  
  149. BEGIN   { Function GetEnv }
  150.  
  151.   EnvArrPtr  := Ptr(EnvSegAbs, $0000);
  152.   Index      := 0;
  153.   FoundValue := '';
  154.  
  155.   While ((EnvArrPtr^[Index] <> Null) AND (FoundValue = '')) DO
  156.     BEGIN
  157.       FoundName := '';
  158.       WHILE (EnvArrPtr^[Index] <> '=') DO    {copy until = sign found}
  159.         Begin
  160.           FoundName := FoundName + EnvArrPtr^[Index];
  161.           Index     := Index + 1;
  162.         End;
  163.       IF (FoundName = SearchName) THEN
  164.         Begin
  165.           Index := Index + 1;               {advance past = sign}
  166.           While (EnvArrPtr^[Index] <> Null) Do
  167.             Begin
  168.               FoundValue := FoundValue + EnvArrPtr^[Index];
  169.               Index      := Index + 1;
  170.             End;
  171.         End
  172.       Else
  173.         Begin
  174.           Repeat
  175.             Index := Index + 1;
  176.           Until (EnvArrPtr^[Index] = Null);
  177.         End;
  178.     End;
  179.  
  180.     GetEnv := FoundValue;
  181.  
  182.     End;           { Function GetEnv }
  183.  
  184.  
  185. Begin              { Function System }
  186.  
  187.   System      := FALSE;
  188.   CommandInt  := GetEnv('COMSPEC');
  189.  
  190.   If (CommandInt = '') Then
  191.     Writeln('** Unable to find DOS Command Interpreter (COMMAND.COM) **')
  192.   Else
  193.     System := Fork(CommandInt, '/C ' + AnyCommand);
  194.  
  195. End;               { Function System }
  196.