Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TP5WIO.ZIP/TP5MISC.PAS

Pascal/Delphi Source File | 1989-03-23 | 11.4 KB | 386 lines

{ TP5MISC.PAS creates a unit which performs misc functions on
  strings.  These have been extracted from tp5wio and the various
  application programs to enable us to manage the source code more
  effectively.  Added File management functions.
                      Revision History
  ------------------------------------------------------------------
  Rel 1.00 Collected procedures and functions from elsewhere     gbr
  Rel 1.10 24 Mar 89 Added File management functions             gbr
}
unit tp5misc;

{ -------------- }
interface
type
   st2     = string[2];
   st4     = string[4];
   st5     = string[5];

function wdtostr(n:word):st2;
         { converts word to packed two char string }
function strtowd(s:st2):word;
         { converts packed two char string to word }
function bttostr(n:byte):st2;
         { converts byte to packed char string }
function strtobt(s:st2):byte;
         { converts packed char string to byte }
function dbasetodate(s:string):longint;
         { convert the dbase sdf date dump (YYYYMMDD) to a longint with
           the same format }
function datetodbase(var dbdate:longint):string;
         { convert the hs date record to dbase sdf date dump (YYYYMMDD) }
function strtointeger(st:st5):integer;
         { Converts a string to integer value, returns -1 on error }
function strtoword(st:st5):word;
         { Converts a string to word value, returns 0 on error }
function strtobyte(st:st5):byte;
         { Converts a string to byte value, returns 0 on error }
FUNCTION PAD (st : string ; ch : char ; i : integer) : string ;
         { Pad string with ch to length of i. }
FUNCTION UPPER (st :string):string;
         { returns upper case of st }
FUNCTION STRIPCH (instr:string ; inchar:char) : string ;
         {Strips leading instances of the character from the string}
FUNCTION TRIM (st:string;len:integer):string;
         { Chops spaces from string or truncates at l length }
FUNCTION CHOPCH (instr:string ; inchar:char) : string ;
         {Chops trailing instances of the character from the string}
FUNCTION INTTOSTR(n:integer):st2;
         { converts integer to packed two char string }
FUNCTION STRTOINT(s:st2):integer;
         { converts packed two char string to integer }
FUNCTION LINTTOST4(n:longint):st4;
         { converts long integer to packed 4 character string }
FUNCTION ST4TOLINT(s:st4):longint;
         { converts packed four character string to longint }
{ --- File tools --- }
FUNCTION EXIST(FN : String) : boolean;
         { Returns true if file named by FN exists }
FUNCTION REMOVE(FN : string):boolean;
         { Erases the file named by FN, returns TRUE if erased }

{ -------------- }
implementation

type
   { the following variant record is used to map a longint to two integers }
   intlong = record
      case integer of
         0 :(lint:longint);
         1 :(lowint,highint:integer);
      end;

function wdtostr(n:word):st2;
{ converts word to packed two char string }
begin
   wdtostr := chr(hi(n)) + chr(lo(n));
end;    { function wdtostr }

{ -------------------------------------------------------------------------- }

function strtowd(s:st2):word;
{ converts packed two char string to word }
begin
   strtowd := swap(ord(s[1])) + ord(s[2]);
end;    { function strtowd }

{ -------------------------------------------------------------------------- }

function bttostr(n:byte):st2;
{ converts byte to packed char string }
begin
   bttostr := chr(n);
end;    { function bttostr }

{ -------------------------------------------------------------------------- }

function strtobt(s:st2):byte;
{ converts packed char string to byte }
begin
   strtobt := ord(s[1]);
end;    { function bttostr }

{ -------------------------------------------------------------------------- }

function dbasetodate(s:string):longint;
{ convert the dbase sdf date dump (YYYYMMDD) to a longint with the same
  format }
    var
      yr,mo,dy,code     :integer ;
      result   :longint;
      i        :byte;

    begin
      for i := 1 to 8 do  { fill to 2 digits of year }
         begin
         if length(s) < i then s := concat(s,'0');
         if s[i] = ' ' then s[i] := '0'; { fill any spaces with 0 }
      end;
      val (copy(s,5,2),mo,code) ;
      if code <> 0 then
         begin
         write ('** MONTH CONVERSION ERROR ',code) ;
         halt
      end ;
      val (copy(s,7,2),dy,code) ;
      if code <> 0 then
         begin
         write ('** DAY CONVERSION ERROR ',code) ;
         halt
      end ;
      val (copy(s,1,4),yr,code) ;
      if code <> 0 then
         begin
         write ('** YEAR CONVERSION ERROR ',code) ;
         halt
      end ;
      if ((yr = 0) and (mo = 0) and (dy = 0)) then { default to nodate }
         dbasetodate := 0
      else
         begin
         result := yr;
         result := (result * 100) + mo;
         result := (result * 100) + dy;
         dbasetodate := result;
      end;
end;  {function dbasetodate}

{ -------------------------------------------------------------------------- }

function datetodbase(var dbdate:longint):string;
{ convert the hs date record to dbase sdf date dump (YYYYMMDD) }
var
   yr,mo,dy,i  :integer;
   result      :longint;
   stmo,stdy   :string[2];
   styr        :string[4];
begin
   if dbdate = 0 then datetodbase := '        '
   else
      begin
      dy := (dbdate mod 100);
      result := (dbdate - dy); { subtract the number of days }
      result := result div 100;  { move to right }
      mo := (result mod 100);  { get the month }
      yr := (result div 100); { get year }
      str(yr:1,styr);
      str(mo:1,stmo);
      if length(stmo) = 1 then stmo := concat('0',stmo);
      str(dy:1,stdy);
      if length(stdy) = 1 then stdy := concat('0',stdy);
      datetodbase  := concat(styr,stmo,stdy);
   end;
end;  {function datetodbase}

{ -------------------------------------------------------------------------- }

function strtointeger(st:st5):integer;
{ Converts a string to integer value, returns -1 on error }
var
   i,result :integer;
   s1    :string[5];
begin
   s1 := '';
   for i := 1 to length(st) do
      if st[i] <> ' ' then
         s1 := concat(s1,st[i]);
   val(s1,i,result);
   if result = 0 then
      strtointeger := i
   else
      strtointeger := -1;
end;   {function strtointeger}

{ -------------------------------------------------------------------------- }

function strtoword(st:st5):word;
{ Converts a string to word value, returns 0 on error }
var
   i,result :integer;
   wd       :word;
   s1    :string[5];
begin
   s1 := '';
   for i := 1 to length(st) do
      if st[i] <> ' ' then
         s1 := concat(s1,st[i]);
   val(s1,wd,result);
   if result = 0 then
      strtoword := wd
   else
      strtoword := 0;
end;   {function strtoword}

{ -------------------------------------------------------------------------- }

function strtobyte(st:st5):byte;
{ Converts a string to byte value, returns 0 on error }
var
   i,result :integer;
   bt       :byte;
   s1    :string[5];
begin
   s1 := '';
   for i := 1 to length(st) do
      if st[i] <> ' ' then
         s1 := concat(s1,st[i]);
   val(s1,bt,result);
   if result = 0 then
      strtobyte := bt
   else
      strtobyte := 0;
end;   {function strtobyte}

{ -------------------------------------------------------------------------- }

FUNCTION UPPER(st :string):string;
{ make string upper case }
var i:integer;
begin
   if (length(st) > 0) then
      for i := 1 to length(st) do st[i] := upcase(st[i]);
   upper := st;
end;  {function upper}

{ -------------------------------------------------------------------------- }

function pad(st : string ; ch : char ; i : integer) : string;
{ Pad string with ch to length of i }
var
  l : integer ;
begin
  l := length(st);
  if l > i then st := copy(st,1,i); { if too long then shorten it }
  if l < i then
    begin
      fillchar (st[l+1],i-l,ch);
      st[0] := chr(i)
    end ;
  pad := st
end;

{ -------------------------------------------------------------------------- }

function stripch(instr:string ; inchar:char) : string;
{Strips leading instances of the character from the string}
begin
   while not (length(instr) = 0) and (instr[1] = inchar) do
      delete (instr, 1, 1);
   stripch := instr
end ;

{ -------------------------------------------------------------------------- }

function chopch(instr:string ; inchar:char) : string;
{Chops trailing instances of the character from the string}
begin
   while not (length(instr) = 0) and (instr[length(instr)] = inchar) do
      delete (instr, length(instr), 1);
   chopch := instr
end ;

{ -------------------------------------------------------------------------- }

function inttostr(n:integer):st2;
{ converts integer to packed two char string }
begin
   n := n + (-32768);
   inttostr := chr(hi(n)) + chr(lo(n));
end;    { function inttostr }

{ -------------------------------------------------------------------------- }

function strtoint(s:st2):integer;
{ converts packed two char string to integer }
begin
   strtoint := swap(ord(s[1])) + ord(s[2]) + (-32768);
end;    { function strtoint }

{ -------------------------------------------------------------------------- }

function linttost4(n:longint):st4;
{ converts a long integer to a 4 character string for indexes }
var intrec :intlong;
    s1,s2  :string[2];
begin
   intrec.lint := n;
   s1 := chr(hi(intrec.lowint)) + chr(lo(intrec.lowint));
   s2 := chr(hi(intrec.highint)) + chr(lo(intrec.highint));
   linttost4 := concat(s2,s1);
end;  {function linttost4}

{ -------------------------------------------------------------------------- }

function st4tolint(s:st4):longint;
{ converts a packed 4 character string back to a longint }
var intrec :intlong;
    st     :string[2];
begin
   st := copy(s,3,2);
   intrec.lowint := swap(ord(st[1])) + ord(st[2]);
   st := copy(s,1,2);
   intrec.highint := swap(ord(st[1])) + ord(st[2]);
   st4tolint := intrec.lint;
end;  {function st4tolint}

{ -------------------------------------------------------------------------- }

function trim(st:string;len:integer):string;
{ trims right blanks from string and returns a string of len or less }
var
   i   :integer;

begin
   if length(st) > len then trim := copy(st,1,len)
   else
      begin
      i := length(st);
      while (i >= 1) and (st[i] = ' ') do i := i - 1;
      if i = 0 then trim := ''
         else trim := copy(st,1,i);
   end;
end;  { function trim }

{ ------------------------------------------------------------ }

function Exist(FN : String) : boolean;
{ Returns true if file named by FN exists }
var
   F : file;
   found : boolean;
begin
   Assign(f, FN);
   {$I-}
   Reset(f);
   Found := (IOResult = 0);
   if Found then
      Close(f);
   {$I+}
   Exist := Found;
end; { Exist }

{ ------------------------------------------------------------ }

function Remove(FN : string):boolean;
{ Erases the file named by FN, returns TRUE if erased }
var
   F : File;
begin
   remove := false;   { default to not erased }
   Assign(F, FN);
   {$I-}
   Reset(F);
   if IOResult = 0 then
   begin
      Close(F);
      Erase(F);
      remove := true; { flag as erased }
   end;
   {$I+}
end; { Remove }

{ ---- end of implementation ---- }

begin     { --- initialization --- }
end.  { tp5misc.pas }