home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 15 / CDACTUAL15.iso / cdactual / program / pascal / DML_XREF.ZIP / DMLXREF.ARC / STRG.IMP < prev    next >
Encoding:
Text File  |  1988-12-27  |  10.6 KB  |  362 lines
  1. (**************************************************************************)
  2. (*                                                                        *)
  3. (*          1)  General Purpose String                                    *)
  4. (*                                                                        *)
  5. (*                                                                        *)
  6. (**************************************************************************)
  7.  
  8.  
  9. FUNCTION RJS (Source : STRING; Size : BYTE) : STRING;
  10. VAR
  11.    Temp  : STRING;
  12.    Temp2 : STRING;
  13. BEGIN
  14.    Temp2 := Source;
  15.    IF Length (Temp2) > Size THEN
  16.       Temp2 := COPY (Temp2, Length(Temp2)-Size+1, Size);
  17.    FillChar (Temp [1], MaxStrLen, ' ');
  18.    MOVE (Temp2 [1], Temp [Size-Length(Temp2)+1], Length(Temp2));
  19.    Temp [0] := CHR(Size);
  20.    IF Length (Source) > Size THEN Temp [1] := '^';
  21.    RJS := Temp;
  22. END;
  23.  
  24. FUNCTION LJS (Source : STRING; Size : BYTE) : STRING;
  25. VAR
  26.    Temp : STRING;
  27. BEGIN
  28.    FillChar (Temp [1], MaxStrLen, ' ');
  29.    Temp := Source;
  30.    Temp [0] := CHR(Size);
  31.    IF (Length (Source) > Size) AND (Size > 0) THEN Temp [Size] := '^';
  32.    LJS := Temp;
  33. END;
  34.  
  35. FUNCTION CJS (Source : STRING; Size : BYTE) : STRING;
  36. VAR
  37.    Temp  : STRING;
  38.    Temp2 : STRING;
  39. BEGIN
  40.    Temp2 := Source;
  41.    IF Length (Temp2) > Size THEN
  42.       Temp2 := COPY (Temp2, Length(Temp2)-Size+1, Size);
  43.    FillChar (Temp [1], MaxStrLen, ' ');
  44.    MOVE (Temp2 [1], Temp [((Size-Length(Temp2)) DIV 2)+1], Length(Temp2));
  45.    Temp [0] := Chr (Size);
  46.    IF Length (Source) > Size THEN Temp [1] := '^';
  47.    CJS := Temp;
  48. END;
  49.  
  50. FUNCTION Strip (Source : STRING; Code : BYTE) : STRING;
  51. CONST
  52.   WhiteSpace  : SET OF CHAR = [' ',#9];
  53.   QuoteChars  : SET OF CHAR = [#39,#34];
  54.  
  55.   { QuoteCheck  Return a true if processing inside a quoted string.     }
  56.  
  57.   FUNCTION QuoteCheck (VAR LastQuote : CHAR; Ch : CHAR) : BOOLEAN;
  58.   BEGIN {QuoteCheck}
  59.     IF (Ch IN QuoteChars) THEN BEGIN
  60.       IF (Ch = LastQuote) THEN BEGIN   { The quoted string is closed.   }
  61.         QuoteCheck := FALSE;
  62.         LastQuote  := ' '      { No current quoted string.      }
  63.         END
  64.       ELSE IF (NOT (LastQuote IN QuoteChars)) THEN BEGIN  { A new quoted }
  65.         QuoteCheck := TRUE;
  66.         LastQuote  := Ch
  67.         END
  68.       END
  69.     ELSE IF (LastQuote IN QuoteChars) THEN
  70.       QuoteCheck := TRUE
  71.     ELSE
  72.       QuoteCheck := FALSE
  73.   END; {QuoteCheck}
  74.  
  75. VAR
  76.   Target    : STRING;                { Converted string.              }
  77.   Quote     : BOOLEAN;               { True, when quotes checked.     }
  78.   QuoteOn   : BOOLEAN;               { True, when in a quoted string. }
  79.   LastQuote : CHAR;                  { Quote char used.               }
  80.   DeleteOn  : BOOLEAN;               { True when blanks are reduced   }
  81.   I,J,Len   : INTEGER;
  82.   Ch        : CHAR;
  83.  
  84. BEGIN
  85.   Target    := Source;
  86.   Quote     := (Code AND 16) <> 0;
  87.   QuoteOn   := FALSE;
  88.   LastQuote := ' ';
  89.  
  90.   { First discard all white space (blanks and tabs) }
  91.  
  92.   IF ((Code AND 1) <> 0) THEN BEGIN
  93.     Len := Length (Source);
  94.     I   := 1;
  95.     J   := 0;
  96.     WHILE (I <= Len) DO BEGIN
  97.       Ch := Source[I];
  98.       IF (Quote) THEN QuoteOn := QuoteCheck (LastQuote, Ch);
  99.       IF ((NOT (Ch IN WhiteSpace)) OR QuoteOn) THEN BEGIN
  100.         J := SUCC (J);
  101.         Target [J] := Ch;
  102.         END;
  103.       I := SUCC (I);
  104.       END;
  105.     Target [0] := CHR(J)
  106.     END;
  107.  
  108.   { Now remove all leading white space if requested.  We count the    }
  109.   { white space characters until a non white space character is       }
  110.   { encountered; those characters are deleted.                        }
  111.  
  112.   IF ((Code AND 2) <> 0) THEN BEGIN
  113.     Len := Length(Target);
  114.     I   := 1;
  115.     J   := 0;                     { Number of white space chars    }
  116.     WHILE ((I <= Len) AND (Target[I] in WhiteSpace)) DO BEGIN
  117.       I := SUCC(I);
  118.       J := SUCC(J);
  119.       END;
  120.     DELETE(Target,1,J)            { Remove J white space characters}
  121.     END;
  122.  
  123.   { Remove all trailing white space.   The last non blank, non tabs   }
  124.   { character position is found and the preceding portion is copied.  }
  125.  
  126.   IF ((Code AND 4) <> 0) THEN BEGIN
  127.     Len := Length(Target);
  128.     WHILE ((Len >= 1) AND (Target[Len] IN WhiteSpace)) DO
  129.       Len := Len - 1;
  130.     Target [0] := CHR (Len);
  131.     END;
  132.  
  133.   { Reduce all blanks and tabs to a single blank.  For each character }
  134.   { in the string we check for a blank or tab.  If it is the "first"  }
  135.   { one encountered, a boolean flag is set, and all subsequent ones   }
  136.   { are skipped.  When a non blank, non tab is encountered the flag   }
  137.   { is reset.                                                         }
  138.  
  139.   IF ((Code AND 8) <> 0) THEN BEGIN
  140.     DeleteOn  := FALSE;           { Not deleting blanks            }
  141.     LastQuote := ' ';
  142.     Len       := Length(Target);
  143.     I         := 1;
  144.     J         := 0;
  145.     WHILE (I <= Len) DO BEGIN
  146.       Ch := Target[I];
  147.       IF (Quote) THEN QuoteOn := QuoteCheck(LastQuote,Ch);
  148.       IF ((NOT (Ch IN WhiteSpace)) OR QuoteOn) THEN BEGIN
  149.         J         := Succ(J);
  150.         Target[J] := Ch;
  151.         DeleteOn  := FALSE
  152.         END
  153.       ELSE IF NOT DeleteOn THEN BEGIN
  154.         J         := SUCC(J);
  155.         Target[J] := ' ';
  156.         DeleteOn  := TRUE
  157.         END;
  158.       I := SUCC(I);
  159.       end;
  160.     Target[0] := CHR(J);
  161.     END;
  162.  
  163.   Strip := Target;
  164. END;
  165.  
  166.  
  167. FUNCTION StrCase (Source : STRING; Code : BYTE) : STRING;
  168.  
  169. CONST
  170.     UpperCase   : SET OF CHAR = ['A' .. 'Z'];
  171.     LowerCase   : SET OF CHAR = ['a' .. 'z'];
  172.     QuoteChars  : SET OF CHAR = [#39,#34];
  173.  
  174.   { QuoteCheck  Return a true if processing inside a quoted string.     }
  175.  
  176.   FUNCTION QuoteCheck (VAR LastQuote : CHAR; Ch : CHAR) : BOOLEAN;
  177.   BEGIN {QuoteCheck}
  178.     IF (Ch IN QuoteChars) THEN BEGIN
  179.       IF (Ch = LastQuote) THEN BEGIN   { The quoted string is closed.   }
  180.         QuoteCheck := FALSE;
  181.         LastQuote  := ' '      { No current quoted string.      }
  182.         END
  183.       ELSE IF (NOT (LastQuote IN QuoteChars)) THEN BEGIN  { A new quoted }
  184.         QuoteCheck := TRUE;
  185.         LastQuote  := Ch
  186.         END
  187.       END
  188.     ELSE IF (LastQuote IN QuoteChars) THEN
  189.       QuoteCheck := TRUE
  190.     ELSE
  191.       QuoteCheck := FALSE
  192.   END; {QuoteCheck}
  193.  
  194. VAR
  195.   Target    : STRING;                { Converted string.              }
  196.   Quote     : BOOLEAN;               { True, when quotes checked.     }
  197.   QuoteOn   : BOOLEAN;               { True, when in a quoted string. }
  198.   LastQuote : CHAR;                  { Quote char used.               }
  199.   DeleteOn  : BOOLEAN;               { True when blanks are reduced   }
  200.   I,J,Len   : INTEGER;
  201.   Ch        : CHAR;
  202.  
  203. BEGIN
  204.   Target    := Source;
  205.   Quote     := (Code AND 16) <> 0;   { Check for quoted strings?   }
  206.   QuoteOn   := FALSE;
  207.   LastQuote := ' ';
  208.  
  209.   { Convert lower case characters to upper case.  If a character is   }
  210.   { in the set LowerCase, just subtract 32 from the ASCII code.       }
  211.  
  212.   IF ((Code AND 32) <> 0) THEN BEGIN
  213.     LastQuote := ' ';
  214.     FOR I := 1 TO Length(Target) DO BEGIN
  215.       Ch := Target[I];
  216.       IF Quote THEN QuoteOn := QuoteCheck(LastQuote,Ch);
  217.       IF ((Ch IN LowerCase) AND (NOT QuoteOn)) THEN
  218.         Target[I] := CHR(ORD(Ch)-32)
  219.       END;
  220.     END;
  221.  
  222.   { Convert upper case characters to lower case.  If a character is   }
  223.   { in the set UpperCase, just add 32 to the ASCII code.              }
  224.  
  225.   IF ((Code AND 64) <> 0) THEN BEGIN
  226.     LastQuote := ' ';
  227.     FOR I := 1 TO Length(Target) DO BEGIN
  228.       Ch := Target[I];
  229.       IF Quote THEN QuoteOn := QuoteCheck(LastQuote,Ch);
  230.       IF ((Ch IN UpperCase) AND (NOT QuoteOn)) THEN
  231.         Target[I] := Chr(Ord(Ch) + 32)
  232.       END;
  233.     END;
  234.  
  235.   StrCase := Target
  236. END;
  237.  
  238. FUNCTION StrField (Source : STRING; Delimiter : CHAR; Num : BYTE) : STRING;
  239. {the variable source is destroyed locally.  do not change the variable
  240.  to a VAR or it will be destroyed globally.}
  241. VAR
  242.   I : INTEGER;
  243.   J : INTEGER;
  244.  
  245. BEGIN
  246.   IF POS(Delimiter, Source) = 0 THEN
  247.     IF Num = 1 THEN StrField := Source
  248.                ELSE StrField := ''
  249.   ELSE BEGIN
  250.     FOR I := 1 TO Num - 1 DO BEGIN
  251.       J := POS (Delimiter, Source);
  252.       IF J > 0 THEN
  253.         Source := COPY(Source,J+1,255)
  254.       ELSE
  255.         Source := '';
  256.       END;
  257.  
  258.     IF POS(Delimiter,Source) > 0 THEN
  259.       StrField := COPY(Source,1,POS(Delimiter,Source)-1)
  260.     ELSE
  261.       StrField := Source;
  262.     END;
  263. END;
  264.  
  265. FUNCTION StrFill (FillCh : CHAR; Num : BYTE) : STRING;
  266. VAR
  267.   NewStr : STRING;
  268.  
  269. BEGIN
  270.   FillChar (NewStr[1], Num, FillCh);
  271.   NewStr[0] := CHR(Num);
  272.   StrFill   := NewStr;
  273. END;
  274.  
  275. FUNCTION StrPad   (Source : STRING) : STRING;
  276. VAR
  277.   BigBlank : STRING[MaxStrLen];
  278. BEGIN
  279.   FILLCHAR(BigBlank[1],MaxStrLen,' ');
  280.   BigBlank[0] := CHR(MaxStrLen);
  281.   StrPad := Source + BigBlank;
  282. END;
  283.  
  284. FUNCTION StrShiftLeft  (Fld : STRING; Posit : BYTE) : STRING;
  285. BEGIN
  286.   StrShiftLeft := COPY(Fld,1,Posit-1) + COPY(Fld,Posit+1,LENGTH(Fld));
  287. END;
  288.  
  289. FUNCTION StrShiftRight (Fld : STRING; Posit : BYTE; Fill : CHAR) : STRING;
  290. BEGIN
  291.   StrShiftRight := COPY(Fld,1,Posit-1) + Fill + COPY(Fld,Posit,LENGTH(Fld));
  292. END;
  293.  
  294. {.PA}
  295.  
  296. (**************************************************************************)
  297. (*                                                                        *)
  298. (*          2)  String Conversion                                         *)
  299. (*                                                                        *)
  300. (*                                                                        *)
  301. (**************************************************************************)
  302.  
  303. PROCEDURE S2C (Strg : STRING ; VAR CharA ; Len : BYTE);
  304.  
  305. VAR
  306.   GenPtr : POINTER;
  307.  
  308. BEGIN
  309.   Strg := LJS(Strg,Len);
  310.   GenPtr := PTR(SEG(Strg),OFS(Strg)+1);
  311.   MOVE(GenPtr^,CharA,Len);
  312. END;
  313.  
  314. FUNCTION C2S (VAR CharA ; Len : BYTE) : STRING;
  315.  
  316. VAR
  317.   GenPtr : POINTER;
  318.   Strg   : STRING;
  319.  
  320. BEGIN
  321.   GenPtr := PTR(SEG(CharA),OFS(CharA));
  322.   MOVE(GenPtr^,Strg[1],Len);
  323.   Strg[0] := CHR(Len);
  324.   Strg := Strip(Strg,S_Trailing);
  325.   C2S := Strg;
  326. END;
  327.  
  328. PROCEDURE S2Z (Strg : STRING ; VAR CharA);
  329.  
  330. VAR
  331.   GenPtr     : POINTER;
  332.   Zero       : BYTE;
  333.   CharADummy : ARRAY[1..256] OF CHAR ABSOLUTE CharA;
  334.  
  335. BEGIN
  336.   Zero := 0;
  337.   GenPtr := PTR(SEG(Strg),OFS(Strg)+1);
  338.   MOVE(GenPtr^,CharA,LENGTH(Strg));
  339.   MOVE(Zero,CharADummy[LENGTH(Strg)+1],1);
  340. END;
  341.  
  342. FUNCTION Z2S (VAR CharA) : STRING;
  343.  
  344. VAR
  345.   GenPtr     : POINTER;
  346.   CharADummy : ARRAY[1..256] OF CHAR ABSOLUTE CharA;
  347.   Len        : INTEGER;
  348.   Strg       : STRING;
  349.  
  350. BEGIN
  351.   Len := 0;
  352.   REPEAT
  353.     Len := SUCC(Len);
  354.   UNTIL (CharADummy[Len] = CHR(0)) OR (Len = 256);
  355.   Len := PRED(Len);
  356.   GenPtr := PTR(SEG(CharA),OFS(CharA));
  357.   MOVE(GenPtr^,Strg[1],Len);
  358.   Strg[0] := CHR(Len);
  359.   Z2S := Strg;
  360. END;
  361.  
  362.