ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/UTILITY/EXEC23.ZIP/EXEC.PAS

Pascal/Delphi Source File | 1989-08-03 | 14.8 KB | 579 lines

Unit exec;
{
   EXEC function with memory swap.
   Needs Assembler file 'spawn.asm'.

Public domain software by

        Thomas Wagner
        Ferrari electronic GmbH
        Beusselstrasse 27
        D-1000 Berlin 21
        West Germany

        BIXname: twagner
}

Interface

Uses
  Dos;

type
    filename = pathstr;
    string128 = string [128];


function do_exec (xfn: filename; pars: string128; spwn: integer;
                  needed: word; newenv: boolean): integer;

   { The EXEC function.

      Parameters:    xfn   is a string containing the name of the file
                           to be executed. If the string is empty,
                           the COMSPEC environment variable is used to
                           load a copy of COMMAND.COM or its equivalent.
                           If the filename does not include a path, the
                           current PATH is searched after the default.
                           If the filename does not include an extension,
                           the path is scanned for a COM or EXE file in
                           that order.

                     pars  The program parameters.

                     spwn  If 1, the function will return, if necessary
                           after swapping the memory image.
                           If -1, EMS will not be used during swapping.
                           If 0, the function will terminate after the
                           EXECed program returns.
                           NOTE: If the program file is
                           not found, the function will always return
                           with the appropriate error code, even if
                           'spwn' is 0.

                     needed   The memory needed for the program in
                           paragraphs. If not enough memory is free, the
                           program will be swapped out. Use 0 to never
                           swap, $ffff to always swap. If 'spwn' is false,
                           this parameter is irrelevant.

                     newenv   If this parameter is FALSE, the environment
                           of the spawned program is a copy of the parent's
                           environment. If it is TRUE, a new environment
                           is created which includes the modifications from
                           previous 'putenv' calls.

      Return value:
                           $0000..00FF: The EXECed Program's return code
                           (0..255 decimal)
                           $0100:       Error writing swap file
                           (256 decimal)
                           $0200:       Program file not found
                           (512 decimal)
                           $03xx:       DOS-error-code xx calling EXEC
                           (768..1023 decimal)
                           $0400:       Error allocating environment buffer
                           (1024 decimal)
}


procedure putenv (envvar: string);
{  Adds a string to the environment. Note that the change to the
   environment is valid for an exec'ed process only, and only if you
   set the 'newenv' parameter in do_exec to TRUE. }


function envcount: integer;
function envstr (index: integer): string;
function getenv (envvar: string): string;

{ Replacement functions for the environment handling functions in the
  DOS unit. All three functions work exactly like their DOS-unit
  counterparts, except that they recognize the changes to the child
  environment produced by 'putenv'. }



{===========================================================================}

Implementation

const
   swap_filename = '$$AAAAAA.AAA';

    m_swapping        = $01;
    m_use_ems        = $02;
    m_creat_temp    = $04;
    m_exec            = $80;

type
   stringptr = ^string;
   stringarray = array [0..10000] of stringptr;
   stringarrptr = ^stringarray;
   bytearray = array [0..30000] of byte;
   bytearrayptr = ^bytearray;

var
   envptr: stringarrptr;   { Pointer to the changed environment }
   envcnt: integer;        { Count of environment strings }


function do_spawn (method: byte;
                   var swapfn; var xeqfn; var cmdtail; envlen: word;
                   var env): integer; external;
{$L spawn}


{ Environment routines }

function envcount: integer;

   { Returns count of strings in environment. }

   var
      cnt: integer;
   begin
   if envptr = nil { If not yet changed }
      then envcount := dos.envcount
      else envcount := envcnt;
   end;


function envstr (index: integer): string;

   { Returns environment string 'index' }

   begin
   if envptr = nil { If not yet changed }
      then envstr := dos.envstr (index)
      else if (index <= 0) or (index >= envcnt)
      then envstr := ''
      else if envptr^ [index - 1] = nil
      then envstr := ''
      else envstr := envptr^ [index - 1]^;
   end;


function name_eq (var n1, n2: string): boolean;

   { Compares search string 'n1' with environment string 'n2'.
     Case is insignificant. }

   var
      i: integer;
      eq: boolean;
   begin
   i := 1;
   eq := false;
   while (i <= length (n1)) and (i <= length (n2)) and
         (upcase (n1 [i]) = upcase (n2 [i])) do
      i := i + 1;
   name_eq := (i > length (n1)) and (i <= length (n2)) and (n2 [i] = '=');
   end;


function searchenv (var str: string): integer;

   { Search for environment string, returns index in 'envptr' array.
     Assumes 'envptr' is not NIL. }

   var
      idx: integer;
      found: boolean;
   begin
   idx := 0;
   found := false;

   while (idx < envcnt) and not found do
      begin
      if envptr^ [idx] <> nil
         then found := name_eq (str, envptr^ [idx]^);
      idx := idx + 1;
      end;
   if not found
      then searchenv := -1
      else searchenv := idx - 1;
   end;


function getenv (envvar: string): string;

   { Returns value of environment string specified by name. }

   var
      strp: stringptr;
      eq: integer;
   begin
   if envptr = nil { If not yet changed }
      then getenv := dos.getenv (envvar)
      else begin
      eq := searchenv (envvar);
      if eq < 0
         then getenv := ''
         else begin
         strp := envptr^ [eq];
         eq := pos ('=', strp^);
         getenv := copy (strp^, eq + 1, length (strp^) - eq);
         end;
      end;
   end;


procedure init_envptr;

   { Initialise 'envptr' array. Called when 'putenv' is used for the
     first time. Copies all environment strings into heap storage,
     and builds an array of pointers to this strings. }

   var
      i: integer;
      str: string [255];
   begin
   envcnt := dos.envcount;
   getmem (envptr, envcnt * sizeof (stringptr));
   if envptr = nil
      then exit;
   for i := 0 to envcnt - 1 do
      begin
      str := dos.envstr (i + 1);
      getmem (envptr^ [i], length (str) + 1);
      if envptr^ [i] <> nil
         then envptr^ [i]^ := str;
      end;
   end;


procedure putenv (envvar: string);

   { Adds the string 'envvar' to the environment, or changes the
     environment string if the name is already present. }

   var
      idx, eq: integer;
      help: stringarrptr;
   begin
   if envptr = nil
      then init_envptr;
   if envptr = nil
      then exit;

   eq := pos ('=', envvar);
   if eq = 0
      then exit;
   for idx := 1 to eq do
      envvar [idx] := upcase (envvar [idx]);

   idx := searchenv (envvar);
   if idx >= 0
      then begin
      freemem (envptr^ [idx], length (envptr^ [idx]^) + 1);

      if eq >= length (envvar)
         then envptr^ [idx] := nil
         else begin
         getmem (envptr^ [idx], length (envvar) + 1);
         if envptr^ [idx] <> nil
            then envptr^ [idx]^ := envvar;
         end;
      end
      else if eq < length (envvar)
      then begin
      getmem (help, (envcnt + 1) * sizeof (stringptr));
      if help = nil
         then exit;
      move (envptr^, help^, envcnt * sizeof (stringptr));
      freemem (envptr, envcnt * sizeof (stringptr));
      envptr := help;
      getmem (envptr^ [envcnt], length (envvar) + 1);
      if envptr^ [envcnt] <> nil
         then envptr^ [envcnt]^ := envvar;
      envcnt := envcnt + 1;
      end;
   end;



{ Routines to search for files }


function exists (fn: filename): boolean;

   { Returns TRUE if a file with name 'fn' exists. }

   var
      s: searchrec;
   begin
   findfirst (fn, readonly or hidden or sysfile or archive, s);
   exists := doserror = 0;
   end { exists };


function tryext (var fn: filename): boolean;

   { Try '.COM' and '.EXE' on current filename, modify filename if found. }

   var
      found: boolean;
   begin
   found := exists (fn + '.COM');
   if found
      then fn := fn + '.COM'
      else begin
      found := exists (fn + '.EXE');
      if found
         then fn := fn + '.EXE'
      end;
   tryext := found;
   end;



function findfile (var fn: filename): boolean;

   { Try to find the file 'fn' in the current path. Modifies the filename
     accordingly. }

   var
      path: string [255];
      prfx: filename;
      i, j: integer;
      ext, found: boolean;
   begin
   if fn = ''
      then fn := getenv ('COMSPEC');

   i := pos ('\', fn);
   j := pos ('.', fn);
   if (j < i) and (j > 0)
      then begin
      j := i;
      while (j <= length (fn)) and (fn [j] <> '.') do
         j := j + 1;
      end;
   if (j > 0) and (j = length (fn))
      then fn [0] := pred (fn [0]);

   ext := (j > 0) and (j < length (fn));

   if (ext)
      then found := exists (fn)
      else found := tryext (fn);

   if not found and (i = 0)
      then begin
      path := getenv ('PATH');
      i := 1;
      while i <= length (path) do
         begin
         j := 0;
         while (path [i] <> ';') and (i <= length (path)) do
            begin
            j := j + 1;
            prfx [j] := path [i];
            i := i + 1;
            end;
         i := i + 1;
         if (j > 0)
            then begin
            j := j + 1;
            prfx [j] := '\';
            prfx [0] := chr (j);
            prfx := prfx + fn;
            if ext
               then found := exists (prfx)
               else found := tryext (prfx);
            if found
               then begin
               fn := prfx;
               i := 999;
               end;
            end;
         end;
      end;
   findfile := found;
   end; { findfile }


procedure tempdir (var outfn: filename);

   { Set temporary file path.
     Read "TMP/TEMP" environment. If empty or invalid, clear path.
     If TEMP is drive or drive+backslash only, return TEMP.
     Otherwise check if given path is a valid directory.
     If so, add a backslash, else clear path.
   }
   var
      drive: string [2];
      dir: dirstr;
      name: namestr;
      ext: extstr;
      f: file;
      attr: word;
      regs: registers;

   begin
   outfn := getenv ('TMP');
   if outfn = ''
      then outfn := getenv ('TEMP');

   if outfn = ''
      then exit;

   if outfn [length (outfn)] in ['\', '/']
      then dec (outfn [0]);

   fsplit (outfn, dir, name, ext);
   drive := '';
   if length (dir) > 1
      then if dir [2] = ':'
         then begin
         drive := dir [1] + ':';
         delete (dir, 1, 2);
         end;

   if drive <> ''
      then begin
      regs.ah := $1c;
      regs.dl := ord (upcase (drive [1])) - ord ('A') + 1;
      msdos (regs);
      if regs.al = $ff
         then begin
         outfn := '';
         exit;
         end;
      end;

   if name = ''
      then begin
      if dir <> ''
         then outfn := ''
         else outfn := drive + '\';
      exit;
      end;

   assign (f, outfn);
   getfattr (f, attr);
   if (doserror <> 0) or
      ((attr and directory) = 0) or
      ((attr and readonly) <> 0)
      then outfn := ''
      else outfn := outfn + '\';
   end;


function do_exec (xfn: filename; pars: string128; spwn: integer;
                  needed: word; newenv: boolean): integer;
   var
      swapfn: filename;
      avail: word;
      regs: registers;
      envlen, einx: word;
      idx, len: integer;
      envp: bytearrayptr;
      method: byte;
   begin

   { First, check if the file to execute exists. }

   if not findfile (xfn)
      then begin
      do_exec := $200;
      exit;
      end;

   { Now create a copy of the environment if the user wants it, and
     if the environment has been changed. }

   envlen := 0;
   if newenv and (envptr <> nil)
      then begin
      for idx := 0 to envcnt - 1 do
         envlen := envlen + length (envptr^ [idx]^) + 1;
      if envlen > 0
         then begin
         envlen := envlen + 1;
         getmem (envp, envlen);
         if envp = nil
            then begin
            do_exec := $400;
            exit;
            end;
         einx := 0;
         for idx := 0 to envcnt - 1 do
            begin
            len := length (envptr^ [idx]^);
            move (envptr^ [idx]^ [1], envp^ [einx], len);
            envp^ [einx + len] := 0;
            einx := einx + len + 1;
            end;
         envp^ [einx] := 0;
         end;
      end;

   if spwn = 0
      then method := m_exec    { Mark 'EXEC' function }
      else begin

      { Determine amount of free memory }
      with regs do
         begin
         ax := $4800;
         bx := $ffff;
         msdos (regs);
         avail := regs.bx;
         end;

      { No swapping if available memory > needed }

      if needed < avail
         then method := 0
         else begin

         { Swapping necessary, use 'TMP' or 'TEMP' environment variable
           to determine swap file path if defined. }

         if spwn < 0
            then method := m_swapping
            else method := m_swapping or m_use_ems;

         tempdir (swapfn);

            if (dosversion and $ff) >= 3
                then method := method or m_creat_temp
                else begin
                swapfn := swapfn + swap_filename;
             len := length (swapfn);
             while exists (swapfn) do
                begin
                if (swapfn [len] >= 'Z')
                   then len := len - 1;
                if (swapfn [len] = '.')
                   then len := len - 1;
                swapfn [len] := succ (swapfn [len]);
                end;
                end;
         swapfn [length (swapfn) + 1] := #0;
         end;
      end;

   { All set up, ready to go. }

   swapvectors;
   do_exec := do_spawn (method, swapfn, xfn, pars, envlen, envp^);
   swapvectors;

   { Free the environment buffer if it was allocated. }

   if envlen > 0
      then freemem (envp, envlen);
   end;


{ Initialisation for environment processing }

Begin
envptr := nil;
envcnt := 0;
End.