home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / PASWIZ13.ZIP / SOURCE.ZIP / STRINGS.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1992-10-29  |  9.9 KB  |  404 lines
  1. {   +----------------------------------------------------------------------+
  2.     |                                                                      |
  3.     |        PasWiz  Copyright (c) 1990-1992  Thomas G. Hanlin III         |
  4.     |             3544 E. Southern Ave. #104,  Mesa, AZ 85204              |
  5.     |                                                                      |
  6.     |                     The Pascal Wizard's Library                      |
  7.     |                                                                      |
  8.     +----------------------------------------------------------------------+
  9.  
  10.  
  11.  
  12. Strings:
  13.  
  14.    This unit provides extensions to Pascal's rather minimal string support.
  15.    This includes string trimming, substring extraction, uppercase/lowercase
  16.    conversions (handles names, too), simple encryption and compression,
  17.    assorted searches, advanced comparisons, and other useful tools.
  18.  
  19. }
  20.  
  21.  
  22.  
  23. UNIT Strings;
  24.  
  25.  
  26.  
  27. INTERFACE
  28.  
  29.  
  30.  
  31. FUNCTION Bickel (St1, St2: String): Integer;
  32. FUNCTION BSq (St: String): String;
  33. FUNCTION BUsq (St: String): String;
  34. FUNCTION Cipher (St, Passwd: String): String;
  35. FUNCTION CipherP (St, Passwd: String): String;
  36. FUNCTION Crunch (SubSt, St: String): String;
  37. FUNCTION Dupe (Count: Integer; SubSt: String): String;
  38. FUNCTION Extract (St, Delimiter: String; Index: Integer): String;
  39. FUNCTION Instr (Start: Integer; SubSt, St: String): Integer;
  40. FUNCTION Left (St: String; Len: Integer): String;
  41. FUNCTION LowerCase (St: String): String;
  42. FUNCTION LTrim (St: String): String;
  43. FUNCTION NameCase (St: String): String;
  44. FUNCTION Replace (OldSubSt, NewSubSt, St: String): String;
  45. FUNCTION Reverse (St: String): String;
  46. FUNCTION Right (St: String; Len: Integer): String;
  47. FUNCTION RPos (SubSt, St: String): Integer;
  48. FUNCTION RTrim (St: String): String;
  49. FUNCTION Soundex (St: String): String;
  50. FUNCTION StripCh (ChList, St: String): String;
  51. FUNCTION StripSt (SubSt, St: String): String;
  52. FUNCTION StripType (ChType: Integer; St: String): String;
  53. FUNCTION TypePos (ChType: Integer; St: String): Integer;
  54. FUNCTION UpperCase (St: String): String;
  55.  
  56.  
  57.  
  58. { --------------------------------------------------------------------------- }
  59.  
  60.  
  61.  
  62. IMPLEMENTATION
  63.  
  64.  
  65.  
  66. {$F+}
  67.  
  68. { routines in assembly language }
  69.  
  70. FUNCTION Bickel; external;           { string comparison by Bickel method }
  71. {$L BICKEL}
  72.  
  73. FUNCTION LowerCase; external;        { convert to lowercase }
  74. {$L LOCASE}
  75.  
  76. FUNCTION NameCase; external;         { capitalize a name appropriately }
  77. {$L NAMECASE}
  78.  
  79. FUNCTION UpperCase; external;        { convert to uppercase }
  80. {$L UPCASE}
  81.  
  82. FUNCTION Reverse; external;          { reverse a string }
  83. {$L REVERSE}
  84.  
  85. FUNCTION Soundex; external;          { string comparison by Soundex method }
  86. {$L SOUNDEX}
  87.  
  88. FUNCTION TypePos; external;          { seek a given type of character }
  89. {$L TYPEPOS}
  90.  
  91.  
  92.  
  93. { compress spaces in a string }
  94. FUNCTION BSq (St: String): String;
  95. VAR
  96.    SqSt: String;
  97.    Ptr, RepCount: Integer;
  98. BEGIN
  99.    SqSt := '';
  100.    RepCount := 0;
  101.    FOR Ptr := 1 TO Length(St) DO
  102.       IF (St[Ptr] = ' ') THEN
  103.          INC(RepCount)
  104.       ELSE BEGIN
  105.          CASE RepCount OF
  106.             0: ;
  107.             1: IF (Ptr = 2) THEN
  108.                   SqSt := ' '
  109.                ELSE
  110.                   SqSt[Length(SqSt)] := CHR(ORD(SqSt[Length(SqSt)]) OR $80);
  111.             2: SqSt := SqSt + CHR(ORD(' ') OR $80);
  112.             ELSE SqSt := SqSt + CHR($80) + CHR((RepCount - 3) OR $80);
  113.          END;
  114.          SqSt := SqSt + St[Ptr];
  115.          RepCount := 0;
  116.       END;
  117.    { flush any remaining spaces }
  118.    CASE RepCount OF
  119.       0: ;
  120.       1: IF (St = ' ') THEN
  121.             SqSt := ' '
  122.          ELSE
  123.             SqSt[Length(SqSt)] := CHR(ORD(SqSt[Length(SqSt)]) OR $80);
  124.       2: SqSt := SqSt + CHR(ORD(' ') OR $80)
  125.       ELSE SqSt := SqSt + CHR($80) + CHR((RepCount - 3) OR $80);
  126.    END;
  127.    BSq := SqSt;
  128. END;
  129.  
  130.  
  131.  
  132. { uncompress a string processed by BSq }
  133. FUNCTION BUsq (St: String): String;
  134. VAR
  135.    UnsqSt: String;
  136.    Ptr: Integer;
  137. BEGIN
  138.    UnsqSt := '';
  139.    Ptr := 1;
  140.    WHILE (Ptr <= Length(St)) DO
  141.       CASE ORD(St[Ptr]) OF
  142.          0..$7F:    { ordinary chars }
  143.             BEGIN
  144.                UnsqSt := UnsqSt + St[Ptr];
  145.                INC(Ptr);
  146.             END;
  147.          $80:       { RLE sequence }
  148.             BEGIN
  149.                UnsqSt := UnsqSt + Dupe((ORD(St[Ptr + 1]) AND $7F) + 3, ' ');
  150.                INC(Ptr, 2);
  151.             END;
  152.          $81..$FF:  { character followed by one space }
  153.             BEGIN
  154.                UnsqSt := UnsqSt + CHR(ORD(St[Ptr]) AND $7F) + ' ';
  155.                INC(Ptr);
  156.             END;
  157.       END;
  158.    BUsq := UnsqSt;
  159. END;
  160.  
  161.  
  162.  
  163. { encipher or decipher a string }
  164. FUNCTION Cipher (St, Passwd: String): String;
  165. VAR
  166.    SPtr, PPtr: Integer;
  167. BEGIN
  168.    IF (Length(Passwd) > 0) THEN BEGIN
  169.       PPtr := 1;
  170.       FOR SPtr := 1 TO Length(St) DO BEGIN
  171.          St[SPtr] := CHR(Ord(St[SPtr]) XOR Ord(Passwd[PPtr]));
  172.          INC(PPtr);
  173.          IF (PPtr > Length(Passwd)) THEN PPtr := 1;
  174.       END;
  175.    END;
  176.    Cipher := St;
  177. END;
  178.  
  179.  
  180.  
  181. { encipher or decipher a string, with printable results }
  182. FUNCTION CipherP (St, Passwd: String): String;
  183. VAR
  184.    SPtr, PPtr: Integer;
  185. BEGIN
  186.    IF (Length(Passwd) > 0) THEN BEGIN
  187.       PPtr := 1;
  188.       FOR SPtr := 1 TO Length(St) DO BEGIN
  189.          St[SPtr] := CHR(Ord(St[SPtr]) XOR Ord(Passwd[PPtr]) XOR $80);
  190.          INC(PPtr);
  191.          IF (PPtr > Length(Passwd)) THEN PPtr := 1;
  192.       END;
  193.    END;
  194.    CipherP := St;
  195. END;
  196.  
  197.  
  198.  
  199. { remove adjacent occurrences of a given substring from a string }
  200. FUNCTION Crunch (SubSt, St: String): String;
  201. VAR
  202.    Two: String;
  203.    Posn: Integer;
  204. BEGIN
  205.    IF (Length(SubSt) > 0) THEN BEGIN
  206.       Two := SubSt + SubSt;
  207.       REPEAT
  208.          Posn := Pos(Two, St);
  209.          IF (Posn > 0) THEN
  210.             Delete(St, Posn, Length(SubSt));
  211.       UNTIL (Posn = 0);
  212.    END;
  213.    Crunch := St;
  214. END;
  215.  
  216.  
  217.  
  218. { form a string of repeated substrings }
  219. FUNCTION Dupe (Count: Integer; SubSt: String): String;
  220. VAR
  221.    St: String;
  222. BEGIN
  223.    St := '';
  224.    WHILE (Count > 0) DO BEGIN
  225.       St := St + SubSt;
  226.       DEC(Count);
  227.    END;
  228.    Dupe := St;
  229. END;
  230.  
  231.  
  232.  
  233. { extract a substring from a string partitioned by delimiters }
  234. FUNCTION Extract (St, Delimiter: String; Index: Integer): String;
  235. VAR
  236.    Start, SLen, Posn: Integer;
  237. BEGIN
  238.    Start := 1;
  239.    IF ((Index > 0) AND (Length(Delimiter) > 0)) THEN BEGIN
  240.       REPEAT
  241.          Posn := Instr(Start, Delimiter, St);
  242.          DEC(Index);
  243.          IF (Index = 0) THEN
  244.             IF (Posn > 0) THEN
  245.                SLen := Posn - Start
  246.             ELSE
  247.                SLen := Length(St) - Start + 1
  248.          ELSE IF (Posn = 0) THEN
  249.             SLen := 0
  250.          ELSE
  251.             Start := Posn + Length(Delimiter);
  252.       UNTIL ((Posn = 0) OR (Index = 0));
  253.    END
  254.    ELSE
  255.       SLen := 0;
  256.    Extract := Copy(St, Start, SLen);
  257. END;
  258.  
  259.  
  260.  
  261. { search for a substring within a string (like Pos but with start position) }
  262. FUNCTION Instr (Start: Integer; SubSt, St: String): Integer;
  263. VAR
  264.    Posn: Integer;
  265. BEGIN
  266.    Posn := Pos(SubSt, Copy(St, Start, 255));
  267.    IF (Posn > 0) THEN
  268.       Posn := Posn + Start - 1;
  269.    Instr := Posn;
  270. END;
  271.  
  272.  
  273.  
  274. { return part of a string starting from the left side }
  275. FUNCTION Left (St: String; Len: Integer): String;
  276. BEGIN
  277.    Left := Copy(St, 1, Len);
  278. END;
  279.  
  280.  
  281.  
  282. { trim blanks from the left side of a string }
  283. FUNCTION LTrim (St: String): String;
  284. BEGIN
  285.    WHILE (Copy(St, 1, 1) = ' ') DO
  286.       Delete(St, 1, 1);
  287.    LTrim := St;
  288. END;
  289.  
  290.  
  291.  
  292. { replace a given substring with another }
  293. FUNCTION Replace (OldSubSt, NewSubSt, St: String): String;
  294. VAR
  295.    Tmp: String;
  296.    Posn: Integer;
  297. BEGIN
  298.    IF (Length(OldSubSt) > 0) THEN BEGIN
  299.       Tmp := '';
  300.       REPEAT
  301.          Posn := Pos(OldSubSt, St);
  302.          IF (Posn > 0) THEN BEGIN
  303.             Tmp := Tmp + Copy(St, 1, Posn - 1) + NewSubSt;
  304.             Delete(St, 1, Posn + Length(OldSubSt) - 1);
  305.          END
  306.          ELSE
  307.             Tmp := Tmp + St;
  308.       UNTIL (Posn = 0);
  309.       Replace := Tmp;
  310.    END
  311.    ELSE
  312.       Replace := St;
  313. END;
  314.  
  315.  
  316.  
  317. { return part of a string starting from the right side }
  318. FUNCTION Right (St: String; Len: Integer): String;
  319. BEGIN
  320.    IF (Len >= Length(St)) THEN
  321.       Right := St
  322.    ELSE
  323.       Right := Copy(St, Length(St) - Len + 1, 255);
  324. END;
  325.  
  326.  
  327.  
  328. { search for a substring, starting from the right side of a string }
  329. FUNCTION RPos (SubSt, St: String): Integer;
  330. VAR
  331.    Posn: Integer;
  332. BEGIN
  333.    Posn := Pos(Reverse(SubSt), Reverse(St));
  334.    IF (Posn > 0) THEN
  335.       Posn := Length(St) - Length(SubSt) - Posn + 2;
  336.    RPos := Posn;
  337. END;
  338.  
  339.  
  340.  
  341. { trim blanks from the right side of a string }
  342. FUNCTION RTrim (St: String): String;
  343. BEGIN
  344.    WHILE (Copy(St, Length(St), 1) = ' ') DO
  345.       Delete(St, Length(St), 1);
  346.    RTrim := St;
  347. END;
  348.  
  349.  
  350.  
  351. { strip all occurrences of a list of characters from a string }
  352. FUNCTION StripCh (ChList, St: String): String;
  353. VAR
  354.    Ptr: Integer;
  355.    Tmp: String;
  356. BEGIN
  357.    Tmp := '';
  358.    IF (Length(ChList) > 0) THEN
  359.       FOR Ptr := 1 TO Length(St) DO
  360.          IF (Pos(St[Ptr], ChList) = 0) THEN
  361.             Tmp := Tmp + St[Ptr];
  362.    StripCh := Tmp;
  363. END;
  364.  
  365.  
  366.  
  367. { strip all occurrences of a substring from a string }
  368. FUNCTION StripSt (SubSt, St: String): String;
  369. VAR
  370.    Posn: Integer;
  371. BEGIN
  372.    IF ((Length(St) = 0) OR (Length(SubSt) = 0)) THEN
  373.       StripSt := ''
  374.    ELSE BEGIN
  375.       REPEAT
  376.          Posn := Pos(SubSt, St);
  377.          IF (Posn > 0) THEN
  378.             Delete(St, Posn, Length(SubSt));
  379.       UNTIL (Posn = 0);
  380.       StripSt := St;
  381.    END;
  382. END;
  383.  
  384.  
  385.  
  386. { strip all occurrences of given types of character from a string }
  387. FUNCTION StripType (ChType: Integer; St: String): String;
  388. VAR
  389.    Posn: Integer;
  390. BEGIN
  391.    REPEAT
  392.       Posn := TypePos(ChType, St);
  393.       IF (Posn > 0) THEN
  394.          Delete(St, Posn, 1);
  395.    UNTIL (Posn = 0);
  396.    StripType := St;
  397. END;
  398.  
  399.  
  400.  
  401. { ----------------------- initialization code --------------------------- }
  402. BEGIN
  403. END.
  404.