The World of Computer Software/World_Of_Computer_Software-02-385-Vol-1of3.iso/t/tcsel003.zip/SUNDRY.PAS

Pascal/Delphi Source File | 1992-10-28 | 13KB | 458 lines

unit sundry;

interface

uses
  dos,
  scrt,
  strings;

type
  LongWds = record
              loword,hiword : word;
            end;
  ica_rec = record
              case integer of
                0: (bytes   : array[0..15] of byte);
                1: (words   : array[0..7] of word);
                2: (integers: array[0..7] of integer);
                3: (strg    : string[15]);
                4: (longs   : array[0..3] of longint);
                5: (dummy   : string[13]; chksum: integer);
                6: (mix     : byte; wds : word; lng : longint);
            end;
{-This simply creates a variant record which is mapped to 0000:04F0
  which is the intra-applications communications area in the bios area
  of memory. A program may make use of any of the 16 bytes in this area
  and be assured that dos and the bios will not interfere with it. This
  means that it can be effectively used to pass values/information
  between different programs. It can conceivably be used to store
  information from an application, then terminate from that application,
  run several other programs, and then have another program use the
  stored information. As the area can be used by any program, it is wise
  to incorporate a checksum to ensure that the intermediate applications
  have not altered any values. It is of most use when executing child
  processes or passing values between related programs that are run
  consecutively.}

  IOproc = procedure(derror:byte; msg : string);

const
  ValidChars : string[40] = ' ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890-'+#39;
  HexChars : array[0..15] of char = '0123456789ABCDEF';

var
  ica : ica_rec absolute $0000:$04f0;
  FilePosition : longint;
(*  OldRecSize   : word; *)
  TempStr      : string;

procedure CheckIO(Error_action : IOproc; msg : string);

function CompressStr(var n): string;
  {-Will compress 3 alpha-numeric bytes into 2 bytes}

function Decompress(var s): string;
  {-Decompresses a string compressed by CompressStr}

function NumbOfElements(var s; size : word): word;
  {-returns the number of active elements in a set}

function PrinterStatus : byte;
  {-Gets the printer status}

function PrinterReady(var b : byte): boolean;

function TestBbit(n,b: byte): boolean;
function TestWbit(var n; b: byte): boolean;
function TestLbit(n: longint; b: byte): boolean;

procedure SetBbit(var n: byte; b: byte);
procedure SetWbit(var n; b: byte);
procedure SetLbit(var n: longint; b: byte);

procedure ResetBbit(var n: byte; b: byte);
procedure ResetWbit(var n; b: byte);
procedure ResetLbit(var n: longint; b: byte);

function right(var s; n : byte): string;
function left(var s; n : byte): string;
function shleft(var s; n : byte): string;
function nextstr(var s1; s2 : string; n : byte): string;
procedure WriteAtCr(st: string; col,row: byte);
procedure WriteLnAtCr(st: string; col,row: byte);
procedure WriteLNCenter(st: string; width: byte);
procedure WriteCenter(st: string; width: byte);
procedure gotoCR(col,row: byte);

  {-These functions and procedures unit provides the means to do random
    access reads on text files.  }

function Exist(fn : string) : boolean;

function Asc2Str(var s; max: byte): string;

procedure DisableBlink(State:Boolean);

function Byte2Hex(numb : byte) : string;

function Numb2Hex(var numb) : string;

function Long2Hex(long : longint): string;

function Hex2Byte(HexStr : string) : byte;

function Hex2Word(HexStr : string) : word;

function Hex2Integer(HexStr : string) : integer;

function Hex2Long(HexStr : string) : longint;

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


implementation

procedure CheckIO(error_action : IOproc;msg : string);
  var c : word;
  begin
    c := IOResult;
    if c <> 0 then error_action(c,msg);
  end;


{$F+}
procedure ReportError(c : byte; st : string);
  begin
    writeln('I/O Error ',c);
    writeln(st);
    halt(c);
  end;
{$F-}

function CompressStr(var n): string;
  var
    S      : string absolute n;
    InStr  : string;
    len    : byte absolute InStr;
    Compstr: record
              case byte of
                0: (Outlen  : byte;
                    Outarray: array[0..84] of word);
                1: (Out     : string[170]);
             end;
    temp,
    x,
    count : word;
  begin
    FillChar(InStr,256,32);
    InStr := S;
    len   := (len + 2) div 3 * 3;
    FillChar(CompStr.Out,171,0);
    InStr := StUpCase(InStr);
    x := 1; count := 0;
    while x <= len do begin
      temp  := pos(InStr[x+2],ValidChars);
      inc(temp,pos(InStr[x+1],ValidChars) * 40);
      inc(temp,pos(InStr[x],ValidChars) * 1600);
      inc(x,3);
      CompStr.Outarray[count] := temp;
      inc(count);
    end;
    CompStr.Outlen := count shl 1;
    CompressStr := CompStr.Out;
  end;  {-CompressStr}

function Decompress(var s): string;
  var
    CompStr : record
                clen : byte;
                arry : array[0..84] of word;
              end absolute s;
    x,
    count,
    temp    : word;
  begin
    with CompStr do begin
      Decompress[0] := char((clen shr 1) * 3);
      x := 0; count := 1;
      while x <= clen shr 1 do begin
        temp := arry[x] div 1600;
        dec(arry[x],temp*1600);
        Decompress[count] := ValidChars[temp];
        temp := arry[x] div 40;
        dec(arry[x],temp*40);
        Decompress[count+1] := ValidChars[temp];
        temp := arry[x];
        Decompress[count+2] := ValidChars[temp];
        inc(count,3);
        inc(x);
      end;
    end;
  end;

function NumbOfElements(var s; size : word): word;
 {-The variable s can be any set type and size is the SizeOf(s)}
  var
    TheSet : array[1..32] of byte absolute s;
    count,x,y : word;
  begin
    count := 0;
    for x := 1 to size do
      for y := 0 to 7 do
        inc(count, 1 and (TheSet[x] shr y));
    NumbOfElements := count;
  end;

function PrinterStatus : byte;
   var regs   : registers; {-from the dos unit                         }
   begin
     with regs do begin
       dx := 0;            {-The printer number   LPT2 = 1             }
       ax := $0200;        {-The function code for service wanted      }
       intr($17,regs);     {-$17= ROM bios int to return printer status}
       PrinterStatus := ah;{-Bit 0 set = timed out                     }
     end;                  {     1     = unused                        }
   end;                    {     2     = unused                        }
                           {     3     = I/O error                     }
                           {     4     = printer selected              }
                           {     5     = out of paper                  }
                           {     6     = acknowledge                   }
                           {     7     = printer not busy              }

function PrinterReady(var b : byte): boolean;
  begin
    b := PrinterStatus;
    PrinterReady := (b = $90) {-This may vary between printers}
  end;

function TestBbit(n,b: byte): boolean;
  begin
    TestBbit := odd(n shr b);
  end;

function TestWbit(var n; b: byte): boolean;
  var t: word absolute n;
  begin
    if b < 16 then
      TestWbit := odd(t shr b);
  end;

function TestLbit(n: longint; b: byte): boolean;
  begin
    if b < 32 then
      TestLbit := odd(n shr b);
  end;

procedure SetBbit(var n: byte; b: byte);
  begin
    if b < 8 then
      n := n or (1 shl b);
  end;

procedure SetWbit(var n; b: byte);
  var t : word absolute n; {-this allows either a word or integer}
  begin
    if b < 16 then
      t := t or (1 shl b);
  end;

procedure SetLbit(var n: longint; b: byte);
  begin
    if b < 32 then
      n := n or (longint(1) shl b);
  end;

procedure ResetBbit(var n: byte; b: byte);
  begin
    if b < 8 then
      n := n and not (1 shl b);
  end;

procedure ResetWbit(var n; b: byte);
  var t: word absolute n;
  begin
    if b < 16 then
      t := t and not (1 shl b);
  end;

procedure ResetLbit(var n: longint; b: byte);
  begin
    if b < 32 then
      n := n and not (longint(1) shl b);
  end;

function right(var s; n : byte): string;
  var
    st : string absolute s;
    len: byte absolute s;
  begin
    if n >= len then right := st else
    right := copy(st,len+1-n,n);
  end;

function shleft(var s; n : byte): string;
  var
    st   : string absolute s;
    stlen: byte absolute s;
    temp : string;
    len  : byte absolute temp;
  begin
    if n < stlen then begin
      move(st[n+1],temp[1],255);
      len := stlen - n;
      shleft := temp;
    end;
  end;

function left(var s; n : byte): string;
  var
    st  : string absolute s;
    temp: string;
    len : byte absolute temp;
  begin
    temp := st;
    if n < len then len := n;
    left := temp;
  end;

function nextstr(var s1;s2 : string; n : byte): string;
  var
    main   : string absolute s1;
    second : string absolute s2;
    len    : byte absolute s2;
  begin
    nextstr := copy(main,pos(second,main)+len,n);
  end;

procedure WriteAtCr(st: string; col,row: byte);
  begin
    Gotoxy(col,row);
    write(st);
  end;


procedure WriteLnAtCr(st: string; col,row: byte);
  begin
    Gotoxy(col,row);
    writeln(st);
  end;

procedure WriteLnCenter(st: string; width: byte);
  begin
    TempStr := CharStr(' ',(width div 2)-succ((length(st) div 2)));
    st      := TempStr + st;
    writeln(st);
  end;

procedure WriteCenter(st: string; width: byte);
  begin
    TempStr := CharStr(' ',(width div 2)-succ((length(st) div 2)));
    st      := TempStr + st;
    write(st);
  end;

procedure gotoCR(col,row: byte);
  begin
    GotoXY(col,row);
  end;

function Exist(fn : string): boolean;
  var
    f         : file;
    OldMode   : byte;
  begin
    OldMode := FileMode;
    FileMode:= 0;
    assign(f,fn);
    {$I-}  reset(f,1); {$I+}
    if IOResult = 0 then begin
      close(f);
      Exist := true;
    end
    else
      Exist := false;
    FileMode:= OldMode;
  end; {-Exist}

function Asc2Str(var s; max: byte): string;
  var starray : array[0..255] of byte absolute s;
      st      : string;
      len     : byte absolute st;
  begin
    move(starray[0],st[1],255);
    len := max;
    len := (max + word(1)) * ord(pos(#0,st) = 0) + pos(#0,st)-1;
    Asc2Str := st;
  end;


procedure DisableBlink(state : boolean);
   { DisableBlink(true) allows use of upper eight colors as background }
   { colours. DisableBlink(false) restores the normal mode and should  }
   { be called before program exit                                     }
var
   regs : registers;
begin
  with regs do
  begin
    ax := $1003;
    bl := ord(not(state));
  end;
  intr($10,regs);
end;  { DisableBlink }

function Byte2Hex(numb : byte) : string;
  begin
    Byte2Hex[0] := #2;
    Byte2Hex[1] := HexChars[numb shr  4];
    Byte2Hex[2] := HexChars[numb and 15];
  end;

function Numb2Hex(var numb) : string;
  { converts an integer or a word to a string. Using an untyped
    argument makes this possible. }
  var n : word absolute numb;
  begin
    Numb2Hex := Byte2Hex(hi(n))+Byte2Hex(lo(n));
  end;

function Long2Hex(long : longint): string;
  begin
    with LongWds(long) do { type casting makes the split up easy}
      Long2Hex := Numb2Hex(hiword) + Numb2Hex(loword);
  end;

function Hex2Byte(HexStr : string) : byte;
  begin
    Hex2Byte := pos(UpCase(HexStr[2]),HexChars)-1  +
               ((pos(UpCase(HexStr[1]),HexChars))-1) shl  4 { *  16}
  end;

function Hex2Word(HexStr : string) : word;
  { This requires that the string passed is a true hex string  of 4
    chars and not in a format like $FDE0 }
  begin
    Hex2Word := pos(UpCase(HexStr[4]),HexChars)-1  +
               ((pos(UpCase(HexStr[3]),HexChars))-1) shl  4 + { *  16}
               ((pos(UpCase(HexStr[2]),HexChars))-1) shl  8 + { * 256}
               ((pos(UpCase(HexStr[1]),HexChars))-1) shl 12;  { *4096}
  end;

function Hex2Integer(HexStr : string) : integer;
  begin
    Hex2Integer := integer(Hex2Word(HexStr));
  end;

function Hex2Long(HexStr : string) : longint;
  var Long : LongWds;
  begin
    Long.hiword := Hex2Word(copy(HexStr,1,4));
    Long.loword := Hex2Word(copy(HexStr,5,4));
    Hex2Long := longint(Long);
  end;

begin
  FilePosition := 0;
end.