Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TOOLS4.ZIP/TOOLS.PAS

Pascal/Delphi Source File | 1988-08-30 | 4.7 KB | 175 lines

{***************************************************************

  Unit Tools - A set of Turbo Pascal programming tools
  version 1.0 8/30/88
  by Richard S. Sadowsky [74017,1670]

  released to the public domain by author

  This unit was originally written for use with my TC2TP system.
  The source to TC2TP is undergoing some changes, so I thought
  I'd upload these routines.  These routines were written with
  speed in mind.  Most are coded in assembly.  I have included
  the object code for those without an assembler.  I used MASM
  5.1 to develop the ASM code.

  These routines are provided as is.  I welcome comments,
  questions,  and suggestions.  Note: some of these routines
  may appear in other public domain files that I have uploaded.
  Some are completely unique to this unit.

***************************************************************}
{$S-,R-,V-}
Unit Tools;

interface

uses DOS;

const
  _EQUAL_          = 0;


type
  Str3             = String[3];
  Str80            = String[80];
  Path             = String[70];

function UpperCase(S : String) : String;

function CompMem(var Block1,Block2; Size : Word) : Word;
{
 return 0 if Block1 and Block2 are equal for Size bytes
 if not equal, return the position of first non matching byte
 the first byte is considered to be 1
}

function ExpandTabs(var S : String) : String;
{ expands each tab into a single space. Used before parsing }

function Trim(var S : String) : String;
{ FAST assembly language Trim routine, trims leading and trailing }

function SearchBlock(var FindStr; FindSize : Word; var Block;
            BlockSize : Word) : Word;
{ generic Block search routine.  Takes untyped VAR parameters }

procedure ReplaceString(StrToFind,StrToRep : Str80; var S : String);
{ Finds StrToFind and replaces it with StrToRep in string S. }
{ ignores case when searching for the string to replace.     }

function RightStr(S : String; Number : Word) : String;
{ returns all characters to the right of character Number }

function ParseWord(var S : String; DelimChar : Char) : String;
{ parses input string S up to the first occurance of DelimChar. }
{ The parsed string is returned, and chopped out of the string S}
{ see WordOnLine implementation for sample use of ParseWord     }

function WordOnLine(var The_Word,The_Line : String) : Boolean;
{ returns TRUE if The_Word appears on The_Line }

function FileExt(PName : Path; Extension : Str3) : Path;
{ force a file extension }

function InKey(var ScanCode : Byte) : Char;
{ return character and scancode with a single call }

implementation

{ the external Assembly language routines: }

{   MACROS.asm}

{$L UCASE.OBJ}
{$L MEMCOMP.OBJ}
{$L EXPTABS.OBJ}
{$L TRIM.OBJ}
{$L SEARCH.OBJ}
{$L PARSE.OBJ}
{$L INKEY.OBJ}
{$L RIGHTSTR.OBJ}

function UpperCase(S : String) : String; External;

function CompMem(var Block1,Block2; Size : Word) : Word; External;

function ExpandTabs(var S : String) : String; External;

function Trim(var S : String) : String; External;

function SearchBlock(var FindStr; FindSize : Word; var Block;
            BlockSize : Word) : Word; External;

function ParseWord(var S : String; DelimChar : Char) : String; External;

function InKey(var ScanCode : Byte) : Char; External;

function RightStr(S : String; Number : Word) : String; External;

procedure ReplaceString(StrToFind,StrToRep : Str80; var S : String);

var
  L,P              : Word;
  SS               : String; {scratch string }
  STF,STR          : Str80;

begin
  SS := UpperCase(S); {use the scratch string }
  STF := UpperCase(StrToFind);
  STR  := UpperCase(StrToRep);
  L := Length(SS);
  P := SearchBlock(STF[1],Length(STF),SS[1],L);

  if P > 0 then begin
    Delete(S,P,Length(StrToFind));
    if Length(StrToRep) > 0 then
      Insert(StrToRep,S,P);
  end;

end;

function WordOnLine(var The_Word,The_Line : String) : Boolean;
{ returns TRUE if The_Word appears on The_Line }

var
  S                : String; {scratch string }
  Wrd              : Str80;  { the parsed word }

begin
  S := Trim(The_Line);
  while Length(S) > 0 do begin
    Wrd := ParseWord(S,' ');
    S := Trim(S);
    if CompMem(Wrd,The_Word,
               Succ(Length(Wrd))) = _EQUAL_ then begin
      WordOnLine := TRUE;
      Exit;
    end;
  end;
  WordOnLine := FALSE;
end;

function FileExt(PName : Path; Extension : Str3) : Path;

var
  Position,L       : Word;

  PathName         : Path;

const
  Period           : String[1] = '.';

begin
  PathName := PName;
  Position := Pos(Period,PathName);
  if Position > 0 then begin
    L := Length(PathName);
    PathName[0] := Char(L - Succ(L - Position));
  end;
  FileExt := PathName + '.' + Extension;
end;

end.