home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Source Code / Peter Lewis / PNL Libraries / MyStrings.p < prev    next >
Encoding:
Text File  |  1994-09-30  |  9.3 KB  |  417 lines  |  [TEXT/PJMM]
  1. unit MyStrings;
  2.  
  3. interface
  4.  
  5. {$IFC undefined THINK_Pascal}
  6.     uses
  7.         Types;
  8. {$ENDC}
  9.  
  10.     procedure LeftP (var s: str255; len: integer);
  11.     function Left (var s: str255; len: integer): str255;
  12.     procedure LeftAssignP (var s: str255; len: integer; var rhs: str255);
  13.     function LeftAssign (var s: str255; len: integer; var rhs: str255): str255;
  14.     procedure RightP (var s: str255; len: integer);
  15.     function Right (var s: str255; len: integer): str255;
  16.     procedure RightAssignP (var s: str255; len: integer; var rhs: str255);
  17.     function RightAssign (var s: str255; len: integer; var rhs: str255): str255;
  18.     procedure MidP (var s: str255; p, len: integer);
  19.     function Mid (var s: str255; p, len: integer): str255;
  20.     procedure MidAssignP (var s: str255; p, len: integer; var rhs: str255);
  21.     function MidAssign (var s: str255; p, len: integer; var rhs: str255): str255;
  22.     procedure HandleToString (h: univ handle; var s: str255);
  23.     function HandleToStr (h: univ handle): str255;
  24.     procedure StringToHandle (var s: str255; h: univ handle);
  25.     function Trim (s: string): string;
  26.     procedure SplitBy (s: str255; ch: char; var left, right: str255);
  27.     function UpCaseChar (ch: char): char;
  28.     function UpCase (ch: char): char;
  29.     inline
  30.         $301F, $0C00, $0061, $6500, $000E, $0C00, $007B, $6400, $0006, $0400, $0020, $3E80;
  31.     procedure UpCaseString (var s: string);
  32.     function UpCaseStr (s: string): string;
  33. {    procedure SPrintS5V (var dst: str255;var  src,s1, s2, s3, s4, s5: str255);}
  34.     procedure SPrintS5 (var dst: str255; src, s1, s2, s3, s4, s5: str255);
  35.     procedure SPrintS3 (var dst: str255; src, s1, s2, s3: str255);
  36.     function Split (sub, s: str255; var s1, s2: str255): boolean;
  37.     function PosRight (sub, s: str255): integer;
  38.     function SplitRight (sub, s: str255; var s1, s2: str255): boolean;
  39.     function TPcopy (source: string; start, count: integer): string;
  40.     function TPpos (sub, str: string): integer;
  41.     function Match (pattern, name: str255): boolean;
  42.     procedure LimitStringLength (var s: string; len: integer; delimiter: char);
  43.     function StringToOSType(s:str255):OSType;
  44.     
  45. implementation
  46.  
  47.     uses
  48. {$IFC undefined THINK_Pascal}
  49.         Memory, OSUtils, 
  50.  {$ENDC}
  51.         MyTypes, MyMathUtils;
  52.  
  53.  
  54.     procedure LeftP (var s: str255; len: integer);
  55.     begin
  56.         s := TPcopy(s, 1, len);
  57.     end;
  58.  
  59.     function Left (var s: str255; len: integer): str255;
  60.     begin
  61.         Left := TPcopy(s, 1, len);
  62.     end;
  63.  
  64.     procedure LeftAssignP (var s: str255; len: integer; var rhs: str255);
  65.     begin
  66.         s := concat(rhs, TPcopy(s, len + 1, 255));
  67.     end;
  68.  
  69.     function LeftAssign (var s: str255; len: integer; var rhs: str255): str255;
  70.     begin
  71.         LeftAssign := concat(rhs, TPcopy(s, len + 1, 255));
  72.     end;
  73.  
  74.     procedure RightP (var s: str255; len: integer);
  75.         var
  76.             p: integer;
  77.     begin
  78.         p := Length(s) - len;
  79.         if p < 1 then
  80.             p := 1;
  81.         s := TPcopy(s, p, 255);
  82.     end;
  83.  
  84.     function Right (var s: str255; len: integer): str255;
  85.         var
  86.             p: integer;
  87.     begin
  88.         p := Length(s) - len;
  89.         if p < 1 then
  90.             p := 1;
  91.         Right := TPcopy(s, p, 255);
  92.     end;
  93.  
  94.     procedure RightAssignP (var s: str255; len: integer; var rhs: str255);
  95.     begin
  96.         s := concat(TPcopy(s, 1, Length(s) - len), rhs);
  97.     end;
  98.  
  99.     function RightAssign (var s: str255; len: integer; var rhs: str255): str255;
  100.     begin
  101.         RightAssign := concat(TPcopy(s, 1, Length(s) - len), rhs);
  102.     end;
  103.  
  104.     procedure MidP (var s: str255; p, len: integer);
  105.     begin
  106.         s := TPcopy(s, p, len);
  107.     end;
  108.  
  109.     function Mid (var s: str255; p, len: integer): str255;
  110.     begin
  111.         Mid := TPcopy(s, p, len);
  112.     end;
  113.  
  114.     procedure MidAssignP (var s: str255; p, len: integer; var rhs: str255);
  115.     begin
  116.         s := concat(TPcopy(s, 1, p - 1), rhs, TPcopy(s, p + len + 1, 255));
  117.     end;
  118.  
  119.     function MidAssign (var s: str255; p, len: integer; var rhs: str255): str255;
  120.     begin
  121.         MidAssign := concat(TPcopy(s, 1, p - 1), rhs, TPcopy(s, p + len + 1, 255));
  122.     end;
  123.  
  124. {$PUSH}
  125. {$R-}
  126.     procedure HandleToString (h: univ handle; var s: str255);
  127.         var
  128.             len: longInt;
  129.     begin
  130.         len := GetHandleSize(h);
  131.         if len > 255 then
  132.             len := 255;
  133.         s[0] := chr(len);
  134.         BlockMove(h^, @s[1], len);
  135.     end;
  136. {$POP}
  137.  
  138.     function HandleToStr (h: univ handle): str255;
  139.         var
  140.             s: str255;
  141.     begin
  142.         HandleToString(h, s);
  143.         HandleToStr := s;
  144.     end;
  145.  
  146. {$PUSH}
  147. {$R-}
  148.     procedure StringToHandle (var s: str255; h: univ handle);
  149.     begin
  150.         SetHandleSize(h, length(s));
  151.         BlockMove(@s[1], h^, length(s));
  152.     end;
  153. {$POP}
  154.  
  155.     function Trim (s: string): string;
  156.     begin
  157.         while (length(s) > 0) and (s[1] in [spc, tab]) do
  158.             Delete(s, 1, 1);
  159.         while (length(s) > 0) and (s[length(s)] in [spc, tab]) do
  160.             Delete(s, length(s), 1);
  161.         Trim := s;
  162.     end;
  163.  
  164.     procedure UpCaseString (var s: string);
  165.         var
  166.             i: integer;
  167.     begin
  168.         for i := 1 to length(s) do begin
  169.             s[i] := UpCase(s[i]);
  170.         end;
  171.     end;
  172.  
  173.     function UpCaseStr (s: string): string;
  174.         var
  175.             i: integer;
  176.     begin
  177.         for i := 1 to length(s) do
  178.             s[i] := UpCase(s[i]);
  179.         UpCaseStr := s;
  180.     end;
  181.  
  182.     function UpCaseChar (ch: char): char;
  183.     begin
  184.         if ('a' <= ch) & (ch <= 'z') then
  185.             UpCaseChar := chr(ord(ch) - $20)
  186.         else
  187.             UpCaseChar := ch;
  188.     end;
  189.  
  190.     function TPpos (sub, str: string): integer;
  191.         var
  192.             i, ret: integer;
  193.     begin
  194.         if length(sub) = 1 then begin
  195.             ret := 0;
  196.             for i := 1 to length(str) do begin
  197.                 if str[i] = sub[1] then begin
  198.                     ret := i;
  199.                     leave;
  200.                 end;
  201.             end;
  202.         end
  203.         else begin
  204.             ret := Pos(sub, str);
  205.         end;
  206.         TPpos := ret;
  207.     end;
  208.  
  209.     procedure DoSub (var dst: str255; n: integer; var s: str255);
  210.         var
  211.             p: integer;
  212.     begin
  213.         p := TPpos(concat('^', chr(n + 48)), dst);
  214.         if p > 0 then begin
  215.             Delete(dst, p, 2);
  216.             Insert(s, dst, p);
  217.         end;
  218.     end;
  219.  
  220. {$Z+}
  221.     procedure SPrintS5V (var dst: str255; var src, s1, s2, s3, s4, s5: str255);
  222.     begin
  223.         dst := src;
  224.         DoSub(dst, 5, s5);
  225.         DoSub(dst, 4, s4);
  226.         DoSub(dst, 3, s3);
  227.         DoSub(dst, 2, s2);
  228.         DoSub(dst, 1, s1);
  229.     end;
  230. {$Z-}
  231.  
  232.     procedure SPrintS5 (var dst: str255; src, s1, s2, s3, s4, s5: str255);
  233.     begin
  234.         SPrintS5V(dst, src, s1, s2, s3, s4, s5);
  235.     end;
  236.  
  237.     procedure SPrintS3 (var dst: str255; src, s1, s2, s3: str255);
  238.     begin
  239.         dst := src;
  240.         DoSub(dst, 3, s3);
  241.         DoSub(dst, 2, s2);
  242.         DoSub(dst, 1, s1);
  243.     end;
  244.  
  245.     procedure SplitBy (s: str255; ch: char; var left, right: str255);
  246.         var
  247.             p: integer;
  248.     begin
  249.         p := TPpos(ch, s);
  250.         if p <= 0 then begin
  251.             left := s;
  252.             right := '';
  253.         end
  254.         else begin
  255.             left := TPcopy(s, 1, p - 1);
  256.             right := TPcopy(s, p + 1, 255);
  257.         end;
  258.     end;
  259.  
  260.     function Split (sub, s: str255; var s1, s2: str255): boolean;
  261.         var
  262.             p: integer;
  263.     begin
  264.         p := TPpos(sub, s);
  265.         if p > 0 then begin
  266.             s1 := TPcopy(s, 1, p - 1);
  267.             s2 := TPcopy(s, p + length(sub), 255);
  268.         end;
  269.         Split := p > 0;
  270.     end;
  271.  
  272.     function PosRight (sub, s: str255): integer;
  273.         var
  274.             p, q: integer;
  275.     begin
  276.         p := TPpos(sub, s);
  277.         if p > 0 then begin
  278.             q := length(s) - length(sub) + 1;
  279.             while q > p do begin
  280.                 if TPcopy(s, q, length(sub)) = sub then begin
  281.                     p := q;
  282.                 end
  283.                 else begin
  284.                     q := q - 1;
  285.                 end;
  286.             end;
  287.         end;
  288.         PosRight := p;
  289.     end;
  290.  
  291.     function SplitRight (sub, s: str255; var s1, s2: str255): boolean;
  292.         var
  293.             p: integer;
  294.     begin
  295.         p := PosRight(sub, s);
  296.         if p > 0 then begin
  297.             s1 := TPcopy(s, 1, p - 1);
  298.             s2 := TPcopy(s, p + length(sub), 255);
  299.         end;
  300.         SplitRight := p > 0;
  301.     end;
  302.  
  303.     function TPcopy (source: string; start, count: integer): string;
  304.         var
  305.             i: integer;
  306.     begin
  307.         if (start < 1) then begin
  308.             count := count - (1 - start);
  309.             start := 1;
  310.         end;
  311.         if start + count > length(source) then begin
  312.             count := length(source) - start + 1;
  313.         end;
  314.         if count < 0 then begin
  315.             count := 0;
  316.         end;
  317.         source[0] := chr(count);
  318.         BlockMove(@source[start], @source[1], count);
  319.         TPcopy := source;
  320.     end;
  321.  
  322.     function Match (pattern, name: str255): boolean;
  323.         function M (p, n: integer): boolean;
  324.             var
  325.                 state: (searching, failed, success);
  326.         begin
  327.             state := searching;
  328.             while state = searching do begin
  329.                 case ord(p <= length(pattern)) * 2 + ord(n <= length(name)) of
  330.                     0:  begin
  331.                         state := success;
  332.                     end;
  333.                     1:  begin
  334.                         state := failed;
  335.                     end;
  336.                     2:  begin
  337.                         state := success;
  338.                         while p <= length(pattern) do begin
  339.                             if pattern[p] <> '*' then begin
  340.                                 state := failed;
  341.                                 leave;
  342.                             end;
  343.                             p := p + 1;
  344.                         end;
  345.                     end;
  346.                     3:  begin
  347.                         case pattern[p] of
  348.                             '?':  begin
  349.                                 p := p + 1;
  350.                                 n := n + 1;
  351.                             end;
  352.                             '*':  begin
  353.                                 p := p + 1;
  354.                                 if p > length(pattern) then begin { short circuit the * at the end case }
  355.                                     state := success;
  356.                                 end
  357.                                 else begin
  358.                                     state := failed;
  359.                                     while n <= length(name) do begin
  360.                                         if M(p, n) then begin
  361.                                             state := success;
  362.                                             leave;
  363.                                         end;
  364.                                         n := n + 1;
  365.                                     end;
  366.                                 end;
  367.                             end;
  368.                             otherwise begin
  369.                                 if name[n] <> pattern[p] then begin
  370.                                     state := failed;
  371.                                 end;
  372.                                 n := n + 1;
  373.                                 p := p + 1;
  374.                             end;
  375.                         end;
  376.                     end;
  377.                 end;
  378.             end;
  379.             M := state = success;
  380.         end;
  381.     begin
  382.         UprString(pattern, false);
  383.         UprString(name, false);
  384.         Match := M(1, 1);
  385.     end;
  386.  
  387.     procedure LimitStringLength (var s: string; len: integer; delimiter: char);
  388.         var
  389.             p, n, before, after: integer;
  390.     begin
  391.         if length(s) > len then begin
  392.             p := TPpos(delimiter, s);
  393.             if p <= 0 then begin
  394.                 p := length(s) div 2 + 1;
  395.                 Insert(delimiter, s, p);
  396.             end;
  397.             while length(s) > len do begin
  398.                 if p > len div 2 + 1 then begin
  399.                     Delete(s, p - 1, 1);
  400.                     p := p - 1;
  401.                 end
  402.                 else begin
  403.                     Delete(s, p + 1, 1);
  404.                 end;
  405.             end;
  406.         end;
  407.     end;
  408.  
  409.     function StringToOSType(s:str255):OSType;
  410.         var
  411.             t:OSType;
  412.     begin
  413.         s:=concat(s,nul,nul,nul,nul);
  414.         BlockMove(@s[1],@t,4);
  415.         StringToOSType:=t;
  416.     end;
  417. end.