ftp.barnyard.co.uk/2015.02.ftp.barnyard.co.uk.tar/ftp.barnyard.co.uk/cpm/walnut-creek-CDROM/CPM/TURBOPAS/ZINDENT5.LBR/STRING.IQC/STRING.INC

Text File | 2000-06-30 | 11KB | 503 lines

(******************************************************************)
(*  the   STRING.INC   Library of common string  PROCEDURES       *)
(******************************************************************)

(*  v. 0930am, sat, 20.Sep.86, Glen Ellis

pAllCaps (line) upper case full line
pUpCaseFirst (line) upper case first word

pTrim* (line) simple trim spaces
pTrim*Cnt (line,x) trim with counter

pPad* (line,len) simple pad spaces
pPad*Cnt (line,cnt) pad with counter

pExpand* (line,chx,max) complex pad
pShrink* (line,chx,max) complex trim
pJust* (line,len)

pIndent complex required by KEYWORD
pLineCount prefixes linecount str

pSayLineCJ (line);
pSayLineLJ (line);
pSayLineRJ (line);

*)


(********************************************************************)

procedure    pALLCAPS( var LINE : thestr );

var i : integer;

begin
   FOR i := 1 to length(line)
      do  Line[i] := upcase(Line[i]);
end;


(********************************************************************)

procedure    pUpCaseFirst( var LINE : thestr );

var i, max : integer;

begin

   IF pos(' ',line) > 1 then max := pos(' ',line)
   ELSE max := length(line);

   FOR i := 1 to max
      do  Line[i] := upcase(Line[i]);

end;

(********************************************************************)

procedure pTrimL( var line : thestr);

(* line length is shortened *)

var
byte : string1;
len  : integer;

begin (* proc *)
   IF length(line) > 1
   then
   begin
      (* fetch byte on extreme left end *)
      byte := Line[1];
      (* trim left end <space> character, if len > 1 *)
      while byte = ' ' do
      begin
         IF length(line) > 0
         then
         begin
            delete(Line,1,1);
            byte := Line[1];      (* next delete char *)
         end
         ELSE   (* force while loop to exit *)
         byte := '.';
      end; (* while *)
   end; (* if *)
end; (* proc *)


(********************************************************************)

procedure pTrimR(var line : THEstr );

(* line length is shortened *)

var
byte : string1;
len  : integer;

begin (* proc *)
   IF length(line) > 1
   then
   begin
      (* fetch byte on extreme right end *)
      len := length(Line);
      byte := LINE[Len];
      (* trim right end <space> character *)
      WHILE (Byte = ' ') do
      begin
         IF length(line) > 0
         then
         begin
            delete(Line,Len,1);
            Len := length(Line);
            Byte := Line[Len];
         end
         ELSE   (* force while loop to exit *)
         byte := '.';
      end; (* while *)
   end; (* if *)
end; (* proc *)


(********************************************************************)

procedure pTrimLCnt( var Line : thestr ; var Cnt : nbr );

(* line length is shortened *)

var
byte : string1;
len  : integer;

begin (* proc *)
   IF length(line) > 1
   then
   begin
      (* fetch byte on extreme left end *)
      byte := Line[1];
      Cnt := 0;
      (* trim left end <space> character, if len > 1 *)
      WHILE byte = ' '
      do
      begin
         IF length(line) > 0
         then
         begin
            delete(Line,1,1);
            byte := Line[1];      (* next delete char *)
            Cnt := Cnt+1;
         end
         ELSE   (* force while loop to exit *)
         byte := '.';
      end; (* while *)
   end; (* if *)
end; (* proc *)


(********************************************************************)

procedure pTrimRCnt(var Line : THEstr; var Cnt : nbr );

(* line length is shortened *)

var
byte : string1;
len  : integer;

begin (* proc *)
   IF length(line) > 1
   then
   begin
      (* fetch byte on extreme right end *)
      len := length(Line);
      byte := line[Len];
      Cnt := 0;
      (* trim right end <space> character *)
      WHILE (Byte = ' ')
      do
      begin
         IF length(line) > 0
         then
         begin
            delete(Line,Len,1);
            Len := length(Line);
            Byte := Line[Len];
            Cnt := Cnt+1;
         end
         ELSE   (* force while loop to exit *)
         byte := '.';
      end; (* while *)
   end; (* if *)
end; (* proc *)



(********************************************************************)

procedure pPADL(var LINE : THEstr ; LEN : integer);

(* LINE  = incoming string to be altered
(* LEN   = left margin length
*)

var
y : integer;
mark : string1;

begin (* proc *)
   mark   := ' ';
   FOR y := 1 to len
      do line := mark + line;
end; (* proc *)


(********************************************************************)

procedure pPADR(var LINE : THEstr ; LEN : integer);

(* LINE  := incoming string to be altered
(* LEN   := right margin length
*)

var
y : integer;
mark : string1;

begin (* proc *)
   mark   := ' ';
   FOR y := 1 to len
      do line := line + mark;
end; (* proc *)


(***************************************************************************)

procedure pEXPANDL(var LINE :THEstr; CHX :string1; MAX :integer);

(* LINE   = incoming string to be altered
(* CHX   = character to use
(* MAX   = max length of expanded line
*)

var
y : integer;

begin (* proc *)
   WHILE length(line) < max
      do line := chx + line;
end; (* proc *)


(***************************************************************************)

procedure pEXPANDR(var LINE :THEstr; CHX :string1; MAX :integer);

(* LINE   = incoming string to be altered
(* CHX   = character to use
(* MAX   = max length of expanded line
*)

var
y : integer;

begin (* proc *)
   WHILE length(line) < max
      do line := line + chx;
end; (* proc *)


(********************************************************************)

procedure pSHRINKL(var LINE :THEstr; CHX :string1; MIN :integer);

(* shrink the line, not less than minimum length
(* LINE   = incoming string to be altered
(* CHX   = character to use
(* MIN   = min length of shrinked line
*)

begin (* proc *)
   pTRIML(LINE);
   pEXPANDL(LINE,CHX,min);
end; (* proc *)


(********************************************************************)

procedure pSHRINKR(var LINE :THEstr; CHX :string1; MIN :integer);

(* purpose : shrink line, not less than minimum length
(* LINE   = incoming string to be altered
(* CHX   = character to use
(* MIN   = min length of shrinked line
*)

begin (* proc *)
   pTRIMR(LINE);
   pEXPANDR(LINE,CHX,min);
end; (* proc *)


(********************************************************************)

procedure pJUSTL(var LINE :THEstr; LEN :integer);

begin (* proc *)
   pTRIML(LINE);
   pEXPANDR(LINE,' ',len);
end; (* proc *)


(********************************************************************)

procedure pJUSTR(var LINE :THEstr; LEN :integer);

begin (* proc *)
   pTRIMR(LINE);
   pEXPANDL(LINE,' ',len);
end; (* proc *)


(********************************************************************)

procedure pJUSTC(var LINE :THEstr; LEN :integer);

var
x : integer;

begin (* proc *)
   (* scalp the line *)
   pTRIML(line);
   pTRIMR(line);
   (* calc left/right offset *)
   x := ( ( len - length(line)  ) - 1 ) div 2 ;
   (* half pad left, half pad right *)
   pPADL(line,x);
   pPADR(line,x);
end; (* proc *)


(* procedure ***************************************************************)
(* v. 0200pm, wed, 17.Sep.86, Glen Ellis   *)

procedure pSaylineCJ( Line : THEstr; Len : integer );

begin
   pJustC(Line,Len);
   writeln(line);
end;


(* procedure ***************************************************************)
(* v. 0200pm, wed, 17.Sep.86, Glen Ellis   *)

procedure pSayLineLJ( Line : THEstr; Len : integer );

begin
   pJustL(Line,Len);
   writeln(line);
end;


(* procedure ***************************************************************)
(* v. 0200pm, wed, 17.Sep.86, Glen Ellis   *)

procedure pSayLineRJ( Line : THEstr; Len : integer );

begin
   pJustR(Line,Len);
   writeln(line);
end;


(* procedure ***************************************************************)
(* v. 0700am, fri, 12.Sep.86, Glen Ellis   *)

procedure pINDENT( var iLine : THEstr; iPos : integer; iMax : integer);

(* similar to EXPANDL() with control for limit of IlenMAX length.
(* so dBASE2 command Lines do not scroll off screen.
(*
(*  Calling format from KEYWORD
(*  pINDENT( ILINE, IPOS, ILenMax );
*)

(*  as called from KEYDB2 :
(*  Iline  = keyline = line string to altered
(*  Ipos  = keyIpos = position of left margin , currently.
(*  MAX  = lineMAX = max length of line
*)

var
y : integer;

begin (* proc *)
   (* reset begin/end errors *)
   IF IPOS < 0 then
   begin
      iPos := 0;
      writeln('------->   Begin / End Error  <-------',chr(7));
   end;
   FOR y := 1 to iPos do
   begin
      (* if SysIndTrace then write(':',y); *)
      IF (length(iLine) < iMax) then
      iLine := ' ' + iLine;
   end;
end; (* proc *)

(********************************************************************)

procedure pLineCount(var LINE : THEstr; var NUM : integer);

(* purpose : prefix line number count
(*
(* as called by SYSTEM.PAS :
(*
(* LINE  = SysOutStr
(* NUM  = SysLineNum
*)

var
Cnt3 : string3;

begin (* proc *)
   Num := Num + 1;
   str(Num,Cnt3);
   Line := Cnt3 + ': ' + Line
end; (* proc *)


(********************************************************************)

procedure P_NOHIBIT(var HIBITline:string255);

(* not tested, replace hibit *)
(* line length maintained *)

var
I : integer;
WLine : THEstr;
WLineLen : nbr;

begin (* procedure *)
   Wline    := HIBITline ;
   Wlinelen := length(Wline);
   FOR I := 1 to Wlinelen do
   begin
      IF ord(Wline[I]) > 127 then
      begin
         Wline[I] := chr(ord(Wline[I])-128);
      end;
   end;
   (* return this parameter *)
   HIBITline := Wline ;
end; (* procedure *)


(********************************************************************)

procedure P_NOCTRL(var Cline:string255);

(* not tested , needs development *)

(* delete control characters *)
(* line length mainted *)

var
I           : integer;
str1, str2  : string255;
Clinelen    : integer;
Wline       : string255;

begin (* proc *)
   Wline    := Cline ;
   Clinelen := length(Cline);
   FOR I := 1 to Clinelen do
   begin
      (* trap control character *)
      IF ord(Wline[I]) < ord(' ') then
      begin
         (* delete control character *)
         str1 := copy(Cline,1,I-1);
         str2 := copy(Cline,I+1,Clinelen-I);
         (* generate revised workline *)
         Wline := str1 + str2 ;
         i := i-1;
      end;
   end;
   (* return this parameter *)
   Cline := Wline ;
end; (* proc *)

(********************************************************************)

(*:B:0*)
(*:B:0*)
e := Wline ;
end; (* proc *)

(*************************************************