home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / FORK.ZIP / FORK.PAS
Encoding:
Pascal/Delphi Source File  |  1986-08-26  |  3.5 KB  |  108 lines
  1. {Fork.inc}
  2.   CONST CR = #13; Null = #0;
  3.   TYPE AnyString = STRING[255];
  4.   VAR EnvSegAbs : INTEGER ABSOLUTE CSeg:$002C;  {Environment String Segment}
  5. VAR Name, Line:ANYSTRING{FOR TEST};
  6.  
  7.   PROCEDURE FILLCHAR(var temp_item: AnyString; tempb1: BYTE; fchar: CHAR);
  8.   { Fills a variable with a number of fchar }
  9.     VAR i: integer;
  10.     BEGIN
  11.       for i:=1 to tempb1 do temp_item[i]:=fchar; temp_item[0]:=chr(tempb1);
  12.     END; { FILLCHAR PROCEDURE }
  13.  
  14.   FUNCTION DOSErrorMsg(AX: INTEGER):AnyString;
  15.     VAR ErrNumStr : AnyString;
  16.     BEGIN {DOSErrMsg}
  17.       CASE AX OF
  18.         1  : DOSErrorMsg := 'Invalid Function';
  19.         2  : DOSErrorMsg := 'File Not Found';
  20.         3  : DOSErrorMsg := 'Path Not Found';
  21.         4  : DOSErrorMsg := 'Too Many Open Files';
  22.         5  : DOSErrorMsg := 'Access Denied';
  23.         7  : DOSErrorMsg := 'Arena Trashed';
  24.         8  : DOSErrorMsg := 'Not Enough Memory';
  25.         9  : DOSErrorMsg := 'File Not Found';
  26.         10 : DOSErrorMsg := 'Bad Environment';
  27.         11 : DOSErrorMsg := 'Bad Format';
  28.         ELSE BEGIN Str(AX, ErrNumStr); DOSErrorMsg := 'DOS Error ' + ErrNumStr; END
  29.       END; {CASE}
  30.     END; {DOSErrorMsg}
  31.  
  32.   FUNCTION Fork(ProgName, CmdLine: AnyString): BOOLEAN;
  33.     TYPE
  34.       RegType = RECORD AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags: INTEGER; END;
  35.       FCBType = ARRAY [0..36] OF CHAR;
  36.     VAR
  37.       Regs       : RegType;
  38.       Status     : BOOLEAN;
  39.       CmdLen     : BYTE ABSOLUTE CmdLine;
  40.       FCB1, FCB2 : FCBType;
  41.       ParmBlock  : RECORD
  42.                      EnvSeg : INTEGER;
  43.                      CmdPtr : ^AnyString;
  44.                      FCB1Ptr: ^FCBType;
  45.                      FCB2Ptr: ^FCBType;
  46.                    END;
  47.  
  48.     FUNCTION CallDOS(VAR Regs: RegType): BOOLEAN;
  49.       BEGIN {CallDOS}
  50.         MsDOS(Regs);
  51.         CallDOS := (NOT Odd(Regs.Flags));
  52.       END; {CallDOS}
  53.  
  54.     PROCEDURE MakeFCB(CmdLine: AnyString; VAR FCB1, FCB2: FCBType);
  55.     VAR
  56.       Regs      : RegType;
  57.       DummyFlag : BOOLEAN;
  58.  
  59.     BEGIN { MakeFCB }
  60.       FillChar(FCB1, SizeOf(FCB1), 0);
  61.       Regs.AX   := $2901;
  62.       Regs.DS   := Seg(CmdLine[1]);
  63.       Regs.SI   := Ofs(CmdLine[1]);
  64.       Regs.ES   := Seg(FCB1);
  65.       Regs.DI   := Ofs(FCB1);
  66.       DummyFlag := CallDOS(Regs);
  67.  
  68.       FillChar(FCB2, SizeOf(FCB2), 0);
  69.       Regs.AX   := $2901;
  70.       Regs.ES   := Seg(FCB2);
  71.       Regs.DI   := Ofs(FCB2);
  72.       DummyFlag := CallDOS(Regs);
  73.     END; { MakeFCB }
  74.  
  75.   BEGIN { Fork }
  76.     Status := TRUE;
  77.     MakeFCB(CmdLine, FCB1, FCB2);
  78.     ProgName := ProgName + Null;
  79.     CmdLine  := ' ' + CmdLine + CR;
  80.     CmdLen   := PRED(CmdLen);
  81.     WITH ParmBlock DO BEGIN
  82.                         EnvSeg  := EnvSegAbs;
  83.                         CmdPtr  := Addr(CmdLine);
  84.                         FCB1Ptr := Addr(FCB1);
  85.                         FCB2Ptr := Addr(FCB2);
  86.                       END;
  87.     Regs.AX   := $4B00;
  88.     Regs.BX   := Ofs(ParmBlock);
  89.     Regs.DX   := Ofs(ProgName[1]);
  90.     Regs.DS   := Seg(ProgName[1]);
  91.     Regs.ES   := Seg(ParmBlock);
  92.     IF (NOT CallDOS(Regs))
  93.     THEN BEGIN
  94.            Status := FALSE;
  95.            Writeln('Unable to run "', ProgName, '" with "', CmdLine, '" : ',
  96.                     DOSErrorMsg(Regs.AX));
  97.          END;
  98.     Fork := Status;
  99.   END; {Fork}
  100.  
  101. BEGIN {TEST}
  102.   WRITELN('ENTER PROGNAME: ');
  103.   READLN(NAME);
  104.   WRITELN('ENTER CMDLINE: ');
  105.   READLN(LINE);
  106.   IF Fork(NAME, LINE) THEN WRITELN('FORK=TRUE');
  107. END.
  108.