Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/ECO30603.ZIP/ECO30603.LZH/ECOLIBII/eco_env.pas

Pascal/Delphi Source File | 1993-04-05 | 11.0 KB | 483 lines

{$R-,S-,V-,I-,B-,F-}

unit eco_env;

interface

type
  envarray = array[0..32767] of char;
  envarrayptr = ^envarray;
  envrec = record
    envseg : word;              {segment of the environment}
    envlen : word;              {usable length of the environment}
    envptr : pointer;           {nil except when allocated on heap}
  end;


  procedure masterenv(var env : envrec);
  {-return master environment record}

  procedure currentenv(var env : envrec);
  {-return current environment record}

  procedure newenv(var env : envrec; size : word);
  {-allocate a new environment on the heap}

  procedure disposeenv(var env : envrec);
  {-deallocate an environment previously allocated on heap}

  procedure setcurrentenv(env : envrec);
  {-specify a different environment for the current program}

  procedure copyenv(src, dest : envrec);
  {-copy contents of src environment to dest environment}

  function envfree(env : envrec) : word;
  {-return bytes free in environment}

  function getenvstr(env : envrec; search : string) : string;
  {-return a string from the environment}

  function setenvstr(env : envrec; search, value : string) : boolean;
  {-set environment string, returning true if successful}

  procedure dumpenv(env : envrec);
  {-dump the environment to stdout}

  function programstr : string;
  {-return the complete path to the current program, '' if dos < 3.0}

  function setprogramstr(env : envrec; path : string) : boolean;
  {-add a program name to the end of an environment if sufficient space}







implementation







type
  so = record
    o : word;
    s : word;
  end;


  procedure clearenvrec(var env : envrec);
  begin
    fillchar(env, sizeof(env), 0);
  end;


  procedure masterenv(var env : envrec);
  var
    owner : word;
    mcb : word;
    eseg : word;
    done : boolean;

  begin
    with env do begin
      clearenvrec(env);

      {interrupt $2e points into command.com}
      owner := memw[0:(2+4*$2e)];

      {mcb points to memory control block for command}
      mcb := owner-1;
      if (mem[mcb:0] <> byte('M')) or (memw[mcb:1] <> owner) then
        exit;

      {read segment of environment from psp of command}
      eseg := memw[owner:$2c];

      {earlier versions of dos don't store environment segment there}
      if eseg = 0 then begin
        {master environment is next block past command}
        mcb := owner+memw[mcb:3];
        if (mem[mcb:0] <> byte('M')) or (memw[mcb:1] <> owner) then
          {not the right memory control block}
          exit;
        eseg := mcb+1;
      end else
        mcb := eseg-1;

      {return segment and length of environment}
      envseg := eseg;
      envlen := memw[mcb:3] shl 4;
    end;
  end;


  procedure currentenv(var env : envrec);
  var
    eseg : word;
    mcb : word;
  begin
    with env do begin
      clearenvrec(env);
      eseg := memw[prefixseg:$2c];
      mcb := eseg-1;
      if (mem[mcb:0] <> byte('M')) or (memw[mcb:1] <> prefixseg) then
        exit;
      envseg := eseg;
      envlen := memw[mcb:3] shl 4;
    end;
  end;


  procedure newenv(var env : envrec; size : word);
  var mcb : word;
  begin
    with env do if maxavail < size+31 then
      {insufficient space}
      clearenvrec(env)
    else begin
      {31 extra bytes for paragraph alignment, fake mcb}
      getmem(envptr, size+31);
      envseg := so(envptr).s+1;
      if so(envptr).o <> 0 then
        inc(envseg);
      envlen := size;
      {fill it with nulls}
      fillchar(envptr^, size+31, 0);
      {make a fake mcb below it}
      mcb := envseg-1;
      mem[mcb:0] := byte('M');
      memw[mcb:1] := prefixseg;
      memw[mcb:3] := (size+15) shr 4;
    end;
  end;


  procedure disposeenv(var env : envrec);
  begin
    with env do if envptr <> nil then begin
      freemem(envptr, envlen+31);
      clearenvrec(env);
    end;
  end;


  procedure setcurrentenv(env : envrec);
  begin
    with env do if envseg <> 0 then memw[prefixseg:$2c] := envseg;
  end;


  procedure copyenv(src, dest : envrec);
  var
    size : word;
    sptr : envarrayptr;
    dptr : envarrayptr;

  begin
    if (src.envseg = 0) or (dest.envseg = 0) then exit;
    if src.envlen <= dest.envlen then size := src.envlen else
      size := dest.envlen-1;

    sptr := ptr(src.envseg, 0);
    dptr := ptr(dest.envseg, 0);
    move(sptr^, dptr^, size);
    fillchar(dptr^[size], dest.envlen-size, 0);
  end;


  procedure skipasciiz(eptr : envarrayptr; var eofs : word);
  begin
    while eptr^[eofs] <> #0 do inc(eofs);
  end;


  function envnext(eptr : envarrayptr) : word;
  var eofs : word;
  begin
    eofs := 0;
    if eptr <> nil then begin
      while eptr^[eofs] <> #0 do begin
        skipasciiz(eptr, eofs);
        inc(eofs);
      end;
    end;
    envnext := eofs;
  end;


  function envfree(env : envrec) : word;
  begin
    with env do if (
      envseg <> 0
    ) then envfree := envlen-envnext(ptr(envseg, 0))-1 else envfree := 0;
  end;


  function stupcase(s : string) : string;
  var
    slen : byte absolute s;
    i : integer;

  begin
    for i := 1 to slen do s[i] := upcase(s[i]);
    stupcase := s;
  end;


  function searchenv(
    eptr: envarrayptr; var search: string
  ) : word;
  {
    Return the position of Search in environment, or $FFFF if not found.
    Prior to calling SearchEnv, assure EPtr is not nil, Search is not empty
  }
  var
    slen : byte absolute search;
    eofs : word;
    mofs : word;
    sofs : word;
    match : boolean;

  begin
    search := stupcase(search);

    {assure search string ends in =}
    if search[slen] <> '=' then begin
      inc(slen);
      search[slen] := '=';
    end;

    eofs := 0;
    while eptr^[eofs] <> #0 do begin
      {at the start of a new environment element}
      sofs := 1;
      mofs := eofs;
      repeat
        match := (eptr^[eofs] = search[sofs]);
        if match then begin
          inc(eofs);
          inc(sofs);
        end;
      until not match or (sofs > slen);

      if match then begin
        {found a match, return index of start of match}
        searchenv := mofs;
        exit;
      end;
      {skip to end of this environment string}
      skipasciiz(eptr, eofs);
      {skip to start of next environment string}
      inc(eofs);
    end;
    {no match}
    searchenv := $ffff;
  end;


  procedure getasciiz(eptr : envarrayptr; var eofs : word; var estr : string);
  var elen : byte absolute estr;
  begin
    elen := 0;
    while (eptr^[eofs] <> #0) and (elen < 255) do begin
      inc(elen);
      estr[elen] := eptr^[eofs];
      inc(eofs);
    end;
  end;


  function getenvstr(env : envrec; search : string) : string;
  var
    slen : byte absolute search;
    eptr : envarrayptr;
    eofs : word;
    estr : string;
    elen : byte absolute estr;

  begin
    with env do begin
      elen := 0;
      if (envseg <> 0) and (slen <> 0) then begin
        {find the search string}
        eptr := ptr(envseg, 0);
        eofs := searchenv(eptr, search);
        if eofs <> $ffff then begin
          {skip over the search string}
          inc(eofs, slen);
          {build the result string}
          getasciiz(eptr, eofs, estr);
        end;
      end;
      getenvstr := estr;
    end;
  end;


  function setenvstr(env : envrec; search, value : string) : boolean;
  var
    slen : byte absolute search;
    vlen : byte absolute value;
    eptr : envarrayptr;
    enext : word;
    eofs : word;
    mofs : word;
    oldlen : word;
    newlen : word;
    nullen : word;

  begin
    with env do begin
      setenvstr := false;
      if (envseg = 0) or (slen = 0) then exit;
      eptr := ptr(envseg, 0);

      {find the search string}
      eofs := searchenv(eptr, search);

      {get the index of the next available environment location}
      enext := envnext(eptr);

      {get total length of new environment string}
      newlen := slen+vlen;

      if eofs <> $ffff then begin
        {search string exists}
        mofs := eofs+slen;
        {scan to end of string}
        skipasciiz(eptr, mofs);
        oldlen := mofs-eofs;
        {no extra nulls to add}
        nullen := 0;
      end else begin
        oldlen := 0;
        {one extra null to add}
        nullen := 1;
      end;

      if vlen <> 0 then
        {not a pure deletion}
        if enext+newlen+nullen >= envlen+oldlen then
          {new string won't fit}
          exit;

      if oldlen <> 0 then begin
        {overwrite previous environment string}
        move(eptr^[mofs+1], eptr^[eofs], enext-mofs-1);
        {more space free now}
        dec(enext, oldlen+1);
      end;

      {append new string}
      if vlen <> 0 then begin
        move(search[1], eptr^[enext], slen);
        inc(enext, slen);
        move(value[1], eptr^[enext], vlen);
        inc(enext, vlen);
      end;

      {clear out the rest of the environment}
      fillchar(eptr^[enext], envlen-enext, 0);

      setenvstr := true;
    end;
  end;


  procedure dumpenv(env : envrec);
  var
    eofs : word;
    eptr : envarrayptr;

  begin
    with env do begin
      if envseg = 0 then exit;
      eptr := ptr(envseg, 0);
      eofs := 0;
      writeln;
      while eptr^[eofs] <> #0 do begin
        while eptr^[eofs] <> #0 do begin
          write(eptr^[eofs]);
          inc(eofs);
        end;
        writeln;
        inc(eofs);
      end;
      writeln('Bytes free: ', envfree(env));
    end;
  end;


  function dosversion : word;
  inline(
    $b4/$30/  {mov ah,$30}
    $cd/$21/  {int $21}
    $86/$c4   {xchg ah,al}
  );


  function programstr : string;
  var
    eofs : word;
    env : envrec;
    eptr : envarrayptr;
    pstr : string;

  begin
    programstr := '';
    if dosversion < $0300 then exit;
    currentenv(env);
    if env.envseg = 0 then exit;
    {find the end of the current environment}
    eptr := ptr(env.envseg, 0);
    eofs := envnext(eptr);
    {skip to start of path name}
    inc(eofs, 3);
    {collect the path name}
    getasciiz(eptr, eofs, pstr);
    programstr := pstr;
  end;


  function setprogramstr(env : envrec; path : string) : boolean;
  var
    plen : byte absolute path;
    eofs : word;
    numb : word;
    eptr : envarrayptr;

  begin
    setprogramstr := false;
    with env do begin
      if envseg = 0 then exit;
      {find the end of the current environment}
      eptr := ptr(envseg, 0);
      eofs := envnext(eptr);
      {assure space for path}
      if envlen < plen+eofs+4 then exit;
      {put in the count field}
      inc(eofs);
      numb := 1;
      move(numb, eptr^[eofs], 2);
      {skip to start of path name}
      inc(eofs, 2);
      {move the path into place}
      path := stupcase(path);
      move(path[1], eptr^[eofs], plen);
      {null terminate}
      inc(eofs, plen);
      eptr^[eofs] := #0;
      setprogramstr := true;
    end;
  end;


end.