Collection of Tools & Utilities/Collection of Tools and Utilities.iso/pascal/zindent7.zip/ZINSTR.INC

Text File | 1987-03-30 | 14.0 KB | 610 lines

(********************************************************************)
(*                                                                  *)
(*  Include File  STRING.INC                                        *)
(*  Library of common string  PROCEDURES                            *)
(*  v. 0800am, sun, 28.Mar.87, Glen Ellis                           *)
(*                                                                  *)
(********************************************************************)

(*---

Major routines summary :

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

pSayLnCJ (line,linelen);
pSayLnLJ (line,linelen);
pSayLnRJ (line,linelen);

pSayReadCJ (line,linelen,readlen);
pSayReadLM (line,linelen,readlen);

pIndent() left margin restoration used by KeyWord procedures.
pINDENT( var iLine : THEstr; iPos : integer; iMax : integer);

---*)


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

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 pTrimLR( var LRLine : thestr );

(* trim left / trim right *)
(* line length is shortened *)

var
byte : string1;
len  : integer;

begin (* proc *)
   IF length(LRline) > 1 then
   begin
      pTrimR( LRLine );
      pTrimL( LRLine );
   end; (* if *)
end; (* proc *)


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

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

(* trim left and count spaces *)
(* line length is shortened *)
(* Count is useful for restoring, or re-margining a text line. *)

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 );

(* trim right and count spaces *)
(* line length is shortened *)
(* Count is usefile for restoring, or re-margining a text line. *)

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 pTrimLCntR( var LCRline : thestr ; var Cnt : nbr );

(* trim left and count spaces / trim right and without counting spaces *)
(* line length is shortened *)
(* called by KeyWord procedures *)

var
byte : string1;
len  : integer;

begin (* proc *)
   IF length(LCRline) > 1
   then
   begin
      pTrimR( LCRline );
      pTrimLCnt( LCRline, Cnt );
   end;
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);
   pExpandR(line,' ',len);
end; (* proc *)


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

procedure pSayLnCJ( CJline : THEstr; Len : integer );

begin
   pJustC(CJline,Len);
   writeln(CJline);
end;


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

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

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


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

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

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


(* procedure ***************************************************************)
(* v. 0900am, tue, 30.Sep.86, Glen Ellis   *)

procedure pSayReadLM( line : TheStr ; Mgn : integer );

(* called prior to Readln(xxx);   *)

begin
   pTrimL(line);        (* trim off left *)
   pTrimR(line);        (* trim off right side, READLN will fit here *)
   pPadL(line,Mgn);     (* pad left (pseudo center justify *)
   write(line);         (* open line, readln will close line *)
end;


(* procedure ***************************************************************)
(* v. 0900am, tue, 30.Sep.86, Glen Ellis   *)

procedure pSayReadCJ ( line : Thestr ; linelen, readlen : integer );

(* called prior to ReadLn(xxx); *)

var
mgn : integer;

begin
   mgn := ( (linelen - length(line) - readlen ) div 2 )  ;
   pTrimL(line);           (* trim off left *)
   pTrimR(Line);           (* trim off right side, READLN will fit here *)
   pPadL(line,(mgn));      (* pad left (pseudo center justify *)
   write(Line);            (* open line, readln will close line *)
end;



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

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

(* *)
(* author's developmental note to himself :
(*
(* similar to EXPANDL() with control for limit of lenMAX length.
(*
(* purpose :
(* so dBASE2 command Lines do not scroll off screen.
(*  ( dBASE-II Modify Command Editor will truncate lines greater than 80 ! )
(*
(*  Calling format from KEYWORD
(*  pINDENT( ILINE, IPOS, ILenMax );
(**)

(*  example 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('<----------  Too Many Ends !',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);

(* author's develpmental note to himself :
(*
(* purpose :
(*    replaces hibit ascii.
(*    used for text error correction.
(*
(* not tested.
(* could be used for additional ZINDENT function.
(* wrote one similar to this in ZFIND5.PAS.
(* 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);

(* author's develpmental note to himself :
(*
(* purpose :
(*    delete control characters.
(*
(* not tested , needs development.
(* could be used for additional ZINDENT function.
(* wrote one similar to this in ZFIND5.PAS.
(* line length maintained.
(**)

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 *)

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

(*<<<>>>*)