home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 25 / CD_ASCQ_25_1095.iso / dos / prg / tjgold / install.002 / GOLDSTR.PAS < prev    next >
Pascal/Delphi Source File  |  1995-07-12  |  31KB  |  1,249 lines
  1. {--------------------------------------------------------------------------}
  2. {                Product: TechnoJock's Turbo Toolkit                       }
  3. {                Version: GOLD                                             }
  4. {                Build:   1.01                                             }
  5. {                                                                          }
  6. {                Copyright 1986-1995  TechnoJock Software, Inc.            }
  7. {                           All Rights Reserved                            }
  8. {                          Restricted by License                           }
  9. {--------------------------------------------------------------------------}
  10.  
  11.                     {*********************************}
  12.                     {**       Unit:   GOLDSTR       **}
  13.                     {*********************************}
  14.  
  15. {++++++++++++++++++++++++++++++} unit GOLDSTR; {++++++++++++++++++++++++++++}
  16.  
  17. {$I GOLDFLAG.INC}
  18. {$IFNDEF GOLDSTR}
  19.    {$DEFINE GOLDSTR}
  20. {$ENDIF}
  21.  
  22. {++++++++++++++++++++++++++++++++} INTERFACE {+++++++++++++++++++++++++++++++}
  23.  
  24. Uses GoldReal,CRT;
  25.  
  26. const
  27.    MaxAlphaChars = 40;
  28.    MaxSqzChars = 5;
  29.    MaskChr: word = 42;
  30.  
  31.    ThouChr = ',';
  32.    {
  33.    DecimalChr = '.';
  34.    CurrencyChr = '$';
  35.    }
  36.  
  37. type
  38.    StrErrMsgFunc = function (Ecode:integer):string;
  39.  
  40.    StrAlphabet = string[MaxAlphaChars];
  41.  
  42.    gJust = (JustLeft,JustCenter,JustRight);
  43.    gCase = (Lower,Upper,Proper,Leave);
  44.    gCharSet = set of char;
  45.  
  46.    StrSet = record
  47.       EncryptionCode: byte;
  48.       PuncChars: gCharSet;
  49.       LowerStr: StrAlphabet;
  50.       UpperStr: StrAlphabet;
  51.       LineBreak: char;
  52.       TabBreak: char;
  53.       ECode: integer;
  54.       EMsgFunc: StrErrMsgFunc;
  55.       SqzChars: string[MaxSqzChars];
  56.       SuppressErrors: boolean;
  57.    end;
  58.  
  59. var
  60.    StrVars: StrSet;
  61.  
  62. Const
  63.    HiMarker: char = '~';
  64.    Floating = 255;
  65.    NumSet: set of char = ['0','1','2','3','4','5','6','7','8','9'];
  66.    Fmtchars: set of char = ['!','#','@','*'];
  67.    PuncChars: set of char = ['!',',',';',':','.','?','"',''''];
  68.    CRLF:string[2] = #13#10;
  69.  
  70. function LastStrError: integer;
  71. function Replicate(N : byte; Character:char): string;
  72. function PicFormat(Input,Picture:string;Pad:char;RightJustify:boolean): string;
  73. function TruncFormat(Input:string;Start,Len:byte; Pad:char):string;
  74. function Squeeze(L:char;Str:string;Width:byte): string;
  75. function FirstCapitalPos(Str:string): byte;
  76. function FirstCapital(Str:string): char;
  77. function Pad(PadJust:gJust;Str:string;Size:byte;ChPad:char):string;
  78. function PadLeft(Str:string;Size:byte;ChPad:char):string;
  79. function PadCenter(Str:string;Size:byte;ChPad:char):string;
  80. function PadRight(Str:string;Size:byte;ChPad:char):string;
  81. function TabSubStr(Source:string; TabCount:byte):string;
  82. function Last(N:byte;Str:string):string;
  83. function First(N:byte;Str:string):string;
  84. function AdjCase(NewCase:gCase;Str:string):string;
  85. function SetUpper(Str:string):string;
  86. function SetLower(Str:string):string;
  87. function SetProper(Str:string):string;
  88. function OverType(N:byte;StrS,StrT:string):string;
  89. function Strip(L,C:char;Str:string):string;
  90. function LastPos(C:char;Str:string):byte;
  91. function PosAfter(C:char;Str:string;Start:byte):byte;
  92. function LastPosBefore(C:char;Str:string;Last:byte):byte;
  93. function NthPos(Nth:byte;St,Src:string): byte;
  94. function PosWord(Wordno:byte;Str:string):byte;
  95. function WordCnt(Str:string):byte;
  96. function ExtractWords(StartWord,NoWords:byte;Str:string):string;
  97. {numbers}
  98. function ValidInt(Str:string):boolean;
  99. function ValidHEXInt(Str:string):boolean;
  100. function ValidReal(Str:string):boolean;
  101. function StrToInt(Str:string):integer;
  102. function StrToLong(Str:string):Longint;
  103. function LongToFmtStr(Number:longint):string;
  104. function HEXStrToLong(Str:string):longint;
  105. function StrToReal(Str:string):extended;
  106. function RealToStr(Number:extended;Decimals:byte):string;
  107. function IntToStr(Number:longint):string;
  108. function IntToHEXStr(Number:longint;Width:integer):string;
  109. function Decimals (L:byte):byte;
  110. function RealToSciStr(Number:extended; D:byte):string;
  111. function NthNumber(InStr:string;Nth:byte) : char;
  112. {character testing/conversion}
  113. function  IsUpper(K:word): boolean;
  114. function  IsLower(K:word): boolean;
  115. function  IsDigit(K:word): boolean;
  116. function  IsLetter(K:word): boolean;
  117. function  IsPunctuation(K:word): boolean;
  118. function  GetUpCase(Ch:char):char;
  119. function  GetLoCase(Ch:char):char;
  120. function  CapitalWord(W:word):word;
  121. {misc}
  122. function  CharCount(Ch:Char;Str:string):byte;
  123. function  WidestLine(Str:string):byte;
  124. function  LineCount(Str:string):byte;
  125. {encryption}
  126. function  DeCode(Str: string): string;
  127. function  EnCode(Str: string): string;
  128. {unit initialization}
  129.  
  130. procedure StrDefaultSettings;
  131. procedure GoldStrInit;
  132.  
  133. {$IFDEF TTT5}
  134.  
  135. function Str_to_Int(Str:string):integer;
  136. function Str_to_Long(Str:string):longint;
  137. function Str_to_Real(Str:string):real;
  138. function Real_to_str(Number:real;Decimals:byte):string;
  139. function Int_to_Str(Number:longint):string;
  140. function Real_to_SciStr(Number:real; D:byte):string;
  141.  
  142. {$ENDIF}
  143. {+++++++++++++++++++++++++++++} IMPLEMENTATION {+++++++++++++++++++++++++++++}
  144. {$IFOPT F-}
  145.    {$DEFINE FOFF}
  146.    {$F+}
  147. {$ENDIF}
  148. function StrEMsg(ECode:integer): string;
  149. {}
  150. begin
  151.    case Ecode of
  152.       1001: StrEMsg := 'Number to string conversion error';
  153.       1002: StrEMsg := 'String to long conversion error';
  154.       1003: StrEMsg := 'String to real conversion error';
  155.       1004: StrEMsg := 'String to integer conversion error';
  156.       else
  157.          StrEMsg := 'Internal String error';
  158.    end; {case}
  159. end; { StrEMsg }
  160. {$IFDEF FOFF}
  161.    {$F-}
  162.    {$UNDEF FOFF}
  163. {$ENDIF}
  164.  
  165. procedure StrSetError(ECode:integer);
  166. {}
  167. {$IFOPT D+}
  168. var Ch: char;
  169.     Msg: string;
  170. {$ENDIF}
  171. begin
  172.    StrVars.Ecode := ECode;
  173. {$IFOPT D+}  {if debug active display an error message and terminate}
  174.    if (Ecode <> 0) and (StrVars.SuppressErrors = false) then
  175.    begin
  176.       str(Ecode,Msg);
  177.       Msg := Msg+': '+StrVars.EMsgFunc(Ecode);
  178.       writeln(' GoldStr Error - ',Msg);
  179.       Ch := ReadKey;
  180.       if Ch = #27 then
  181.          Halt;
  182.    end;
  183. {$ENDIF}
  184. end; { StrSetError }
  185.  
  186. function LastStrError: integer;
  187. {}
  188. begin
  189.    LastStrError := StrVars.ECode;
  190. end; { LastStrError }
  191.  
  192.                       {******************************}
  193.                       {**  Miscellaneous Routines  **}
  194.                       {******************************}
  195. function Replicate(N: byte; Character:char): string;
  196. {returns a string with Character repeated N times}
  197. var tempstr: string;
  198. begin
  199.     if N = 0 then
  200.        TempStr := ''
  201.     else
  202.     begin
  203.        fillchar(tempstr,N+1,Character);
  204.        Tempstr[0] := chr(N);
  205.     end;
  206.     Replicate := Tempstr;
  207. end; { Replicate }
  208.  
  209. function PicFormat(Input,Picture:string;Pad:char;RightJustify:boolean): string;
  210. {}
  211. var
  212.    TempStr: string;
  213.    I,J,K: byte;
  214. begin
  215.    J := 0;
  216.    if Picture = '' then
  217.       TempStr := Input
  218.    else
  219.    begin
  220.       if RightJustify then
  221.       begin
  222.          J := succ(length(Picture));
  223.          K := length(Input);
  224.          for I := length(Picture) downto 1 do
  225.          begin
  226.             if not (Picture[I] in FmtChars) then
  227.             begin
  228.                TempStr[I] := Picture[I] ;  {force any none format charcters into string}
  229.                dec(J);
  230.             end else    {format character}
  231.             begin
  232.                if K > 0  then
  233.                begin
  234.                   TempStr[I] := Input[K];
  235.                   dec(K);
  236.                end else
  237.                   TempStr[I] := Pad;
  238.             end;
  239.          end;
  240.       end else
  241.       begin
  242.          for I := 1 to length(Picture) do
  243.          begin
  244.             If not (Picture[I] in Fmtchars) then
  245.             begin
  246.                TempStr[I] := Picture[I] ;  {force any none format charcters into string}
  247.                inc(J);
  248.             end else    {format character}
  249.             begin
  250.                If I - J <= length(Input) then
  251.                   TempStr[I] := Input[I - J]
  252.                else
  253.                   TempStr[I] := Pad;
  254.             end;
  255.          end;
  256.       end;
  257.       TempStr[0] := char(length(Picture));  {set initial byte to string length}
  258.    end;
  259.    PicFormat := Tempstr;
  260. end; { PicFormat }
  261.  
  262. function TruncFormat(Input:string;Start,Len:byte; Pad:char):string;
  263. {Returns a substring starting in char position Start for Len bytes; when
  264. necessary, padding with the Pad char}
  265. var L: byte;
  266. begin
  267.    if Start > 1 then
  268.       delete(Input,1,pred(Start));
  269.    L := length(Input);
  270.    if L = Len then
  271.       TruncFormat := Input
  272.    else if L > Len then
  273.       TruncFormat := copy(Input,1,Len)
  274.    else
  275.       TruncFormat := Padleft(Input,Len,Pad);
  276. end; { TruncFormat }
  277.  
  278. function Squeeze(L:char; Str:string;Width:byte): string;
  279. {}
  280. var
  281.    Temp: string;
  282.    Morelen: byte;
  283. begin
  284.    if Width = 0 then
  285.       Squeeze := ''
  286.    else
  287.    begin
  288.       MoreLen := length(StrVars.SqzChars);
  289.       fillchar(Temp[1],Width,' ');
  290.       Temp[0] := chr(Width);
  291.       if length(Str) < Width then
  292.          move(Str[1],Temp[1],length(Str))
  293.       else
  294.       begin
  295.          if upcase(L) = 'L' then
  296.          begin
  297.             move(Str[1],Temp[1],pred(width));
  298.             move(StrVars.SqzChars[1],Temp[pred(Width)],length(StrVars.SqzChars));
  299.          end else
  300.          begin
  301.             move(StrVars.SqzChars[1],Temp[1],MoreLen);
  302.             move(Str[length(Str)-width+succ(MoreLen)],Temp[succ(MoreLen)],Width-pred(MoreLen));
  303.          end;
  304.       end;
  305.       Squeeze := Temp;
  306.    end;
  307. end; { Squeeze }
  308.  
  309. function SqueezePath(L:char; Str:string;Width:byte): string;
  310. {}
  311. begin
  312. {$IFOPT D+}
  313.   { set error: DING BAT! passed length is to short }
  314. {$ELSE}
  315.  
  316. {$ENDIF}
  317.    SqueezePath := Squeeze(L,Str,Width);
  318. end;
  319.  
  320. function FirstCapitalPos(Str : string): byte;
  321. {}
  322. var StrPos: byte;
  323. begin
  324.    StrPos := 1;
  325.    while (StrPos <= length(Str))  and (IsUpper(ord(Str[StrPos])) = false) do
  326.       StrPos := Succ(StrPos);
  327.    if StrPos > length(Str) then
  328.       FirstCapitalPos  := 0
  329.    else
  330.       FirstCapitalPos := StrPos;
  331. end; { FirstCapitalPos }
  332.  
  333. function FirstCapital(Str : string): char;
  334. {}
  335. var B: byte;
  336. begin
  337.    B := FirstCapitalPos(Str);
  338.    if B > 0 then
  339.       FirstCapital := Str[B]
  340.    else
  341.       FirstCapital := #0;
  342. end; { Firstcapital }
  343.  
  344. function Pad(PadJust:gJust;Str:string;Size:byte;ChPad:char):string;
  345. {}
  346. begin
  347.    case PadJust of
  348.       JustLeft:  Pad := PadLeft(Str,Size,ChPad);
  349.       JustCenter:Pad := PadCenter(Str,Size,ChPad);
  350.       JustRight: Pad := PadRight(Str,Size,ChPad);
  351.    end; {case}
  352. end; { Pad }
  353.  
  354. function PadLeft(Str:string;Size:byte;ChPad:char):string;
  355. var temp: string;
  356. begin
  357.    fillchar(Temp[1],Size,ChPad);
  358.    Temp[0] := chr(Size);
  359.    if length(Str) <= Size then
  360.       move(Str[1],Temp[1],length(Str))
  361.    else
  362.       move(Str[1],Temp[1],size);
  363.    PadLeft := Temp;
  364. end; { PadLeft }
  365.  
  366. function PadCenter(Str:string;Size:byte;ChPad:char):string;
  367. {}
  368. var
  369.    Temp: string;
  370.    L: byte;
  371. begin
  372.    fillchar(Temp[1],Size,ChPad);
  373.    Temp[0] := chr(Size);
  374.    L := length(Str);
  375.    if L <= Size then
  376.       move(Str[1],Temp[((Size - L) div 2) + 1],L)
  377.    else
  378.       Temp := copy(Str,1,L);
  379.    PadCenter := temp;
  380. end; { PadCenter }
  381.  
  382. function PadRight(Str:string;Size:byte;ChPad:char):string;
  383. {}
  384. var
  385.   temp: string;
  386.   L: integer;
  387. begin
  388.    fillchar(Temp[1],Size,ChPad);
  389.    Temp[0] := chr(Size);
  390.    L := length(Str);
  391.    if L <= Size then
  392.       move(Str[1],Temp[succ(Size - L)],L)
  393.    else
  394.       move(Str[1],Temp[1],size);
  395.    PadRight := Temp;
  396. end; { PadRight }
  397.  
  398. function TabSubStr(Source:string; TabCount:byte):string;
  399. {}
  400. var
  401.   P: byte;
  402.   Counter:integer;
  403. begin
  404.    Counter := 1;
  405.    if Source[length(Source)] <> StrVars.TabBreak then
  406.       Source := Source + StrVars.TabBreak;
  407.    P := pos(StrVars.TabBreak,Source);
  408.    while (Counter < TabCount) and (P <> 0) do
  409.    begin
  410.       delete(Source,1,P);
  411.       inc(Counter);
  412.       P := pos(StrVars.TabBreak,Source);
  413.    end;
  414.    if Counter = TabCount then
  415.    begin
  416.       if P = 0 then
  417.          TabSubStr := Source
  418.       else
  419.          TabSubStr := copy(Source,1,pred(P));
  420.    end
  421.    else
  422.       TabSubStr := '';
  423. end; {TabSubStr}
  424.  
  425. function Last(N:byte;Str:string):string;
  426. {}
  427. begin
  428.    if N > length(Str) then
  429.       Last := Str
  430.    else
  431.       Last := copy(Str,succ(length(Str) - N),N);
  432. end;  { Last }
  433.  
  434. function First(N:byte;Str:string):string;
  435. {}
  436. begin
  437.    if N > length(Str) then
  438.       First := Str
  439.    else
  440.       First := copy(Str,1,N);
  441. end;  { First }
  442.  
  443. function AdjCase(NewCase:gCase;Str:string):string;
  444. {}
  445. begin
  446.    case Newcase of
  447.       Upper: Str := SetUpper(Str);
  448.       Lower: Str := SetLower(Str);
  449.       Proper: Str := SetProper(Str);
  450.       Leave:{do nothing};
  451.    end;
  452.    AdjCase := Str;
  453. end; { AdjCase }
  454.  
  455. function SetUpper(Str:string):string;
  456. var I: integer;
  457. begin
  458.    for I := 1 to length(Str) do
  459.       Str[I] := GetUpcase(Str[I]);
  460.    SetUpper := Str;
  461. end; { SetUpper }
  462.  
  463. function SetLower(Str:string):string;
  464. var I: integer;
  465. begin
  466.    for I := 1 to length(Str) do
  467.       Str[I] := GetLocase(Str[I]);
  468.    SetLower := Str;
  469. end; { SetLower }
  470.  
  471. function SetProper(Str:string):string;
  472. var I: integer;
  473.   SpaceBefore: boolean;
  474. begin
  475.    SpaceBefore := true;
  476.    Str := SetLower(Str);
  477.    for I := 1 to length(Str) do
  478.       if SpaceBefore and IsLower(ord(Str[I])) then
  479.       begin
  480.          SpaceBefore := False;
  481.          Str[I] := GetUpcase(Str[I]);
  482.       end else
  483.          if (SpaceBefore = False) and (Str[I] = ' ') then
  484.             SpaceBefore := true;
  485.    SetProper := Str;
  486. end; { SetProper }
  487.  
  488. function OverType(N:byte;StrS,StrT:string):string;
  489. {Overlays StrS onto StrT at Pos N}
  490. var L: byte;
  491.     StrN: string;
  492. begin
  493.    L := N + pred(length(StrS));
  494.    if L < length(StrT) then
  495.       L := length(StrT);
  496.    if L > 255 then
  497.       Overtype := copy(StrT,1,pred(N)) + copy(StrS,1,255-N)
  498.    else
  499.    begin
  500.       fillchar(StrN[1],L,' ');
  501.       StrN[0] := chr(L);
  502.       move(StrT[1],StrN[1],length(StrT));
  503.       move(StrS[1],StrN[N],length(StrS));
  504.       OverType := StrN;
  505.    end;
  506. end; { OverType }
  507.  
  508. function Strip(L,C:char;Str:string):string;
  509. {L is left,center,right,all,ends}
  510. var I:  byte;
  511. begin
  512.    case Upcase(L) of
  513.       'L' : begin       {Left}
  514.                while (Str[1] = C) and (length(Str) > 0) do
  515.                   Delete(Str,1,1);
  516.             end;
  517.       'R' : begin       {Right}
  518.                while (Str[length(Str)] = C) and (length(Str) > 0) do
  519.                   Delete(Str,length(Str),1);
  520.             end;
  521.       'B' : begin       {Both left and right}
  522.                while (Str[1] = C) and (length(Str) > 0) do
  523.                   Delete(Str,1,1);
  524.                while (Str[length(Str)] = C) and (length(Str) > 0)  do
  525.                   Delete(Str,length(Str),1);
  526.             end;
  527.       'A' : begin       {All}
  528.                I := 1;
  529.                repeat
  530.                   if (Str[I] = C) and (length(Str) > 0) then
  531.                      Delete(Str,I,1)
  532.                   else
  533.                      I := succ(I);
  534.                until (I > length(Str)) or (Str = '');
  535.             end;
  536.    end;
  537.    Strip := Str;
  538. end;  { Strip }
  539.  
  540. function LastPos(C:char;Str:string):byte;
  541. {}
  542. var I: byte;
  543. begin
  544.    I := succ(length(Str));
  545.    repeat
  546.       dec(I);
  547.    until (I = 0) or (Str[I] = C);
  548.    LastPos := I;
  549. end;  { LastPos }
  550.  
  551. function PosAfter(C:char;Str:string;Start:byte):byte;
  552. {}
  553. var I: byte;
  554. begin
  555.    I := length(Str);
  556.    if (I = 0) or (Start > I) then
  557.       PosAfter := 0
  558.    else
  559.    begin
  560.       dec(Start);
  561.       repeat
  562.          inc(Start)
  563.       until (Start > I) or (Str[Start] = C);
  564.       if Start > I then
  565.          PosAfter := 0
  566.       else
  567.          PosAfter := Start;
  568.    end;
  569. end; { PosAfter }
  570.  
  571. function LastPosBefore(C:char;Str:string;Last:byte):byte;
  572. {}
  573. begin
  574.    Str := copy(Str,1,Last);
  575.    LastPosBefore := LastPos(C,Str);
  576. end; { LostPosBefore }
  577.  
  578. function LocWord(StartAT,Wordno:byte;Str:string):byte;
  579. {local proc used by PosWord and Extract word}
  580. var W, L: integer;
  581.     Spacebefore: boolean;
  582. begin
  583.    if (Str = '') or (wordno < 1) or (StartAT > length(Str)) then
  584.    begin
  585.       LocWord := 0;
  586.       exit;
  587.    end;
  588.    SpaceBefore := true;
  589.    W := 0;
  590.    L := length(Str);
  591.    StartAT := pred(StartAT);
  592.    while (W < Wordno) and (StartAT <= length(Str)) do
  593.    begin
  594.       StartAT := succ(StartAT);
  595.       if SpaceBefore and (Str[StartAT] <> ' ') then
  596.       begin
  597.          W := succ(W);
  598.          SpaceBefore := false;
  599.       end else
  600.          if (SpaceBefore = false) and (Str[StartAT] = ' ') then
  601.             SpaceBefore := true;
  602.    end;
  603.    if W = Wordno then
  604.       LocWord := StartAT
  605.    else
  606.       LocWord := 0;
  607. end; { LocWord }
  608.  
  609. function NthPos(Nth:byte;St,Src:string): byte;
  610. {returns the starting position of the Nth occurrence of St within Src}
  611. var I,N,LenSt: byte;
  612. begin
  613.    N := 0;
  614.    I := 0;
  615.    LenSt := length(St);
  616.    St := SetUpper(St);
  617.    while I < succ((length(Src)-length(St))) do
  618.    begin
  619.       inc(I);
  620.       if (SetUpper(copy(Src,I,LenSt)) = St) then
  621.       begin
  622.          inc(N);
  623.          if (Nth = N) then
  624.          begin
  625.             NthPos := I;
  626.             exit;
  627.          end;
  628.       end;
  629.    end;
  630. end;
  631.  
  632. function PosWord(Wordno:byte;Str:string):byte;
  633. begin
  634.    PosWord := LocWord(1,wordno,Str);
  635. end; { PosWord }
  636.  
  637. function WordCnt(Str:string):byte;
  638. var
  639.   W,I: integer;
  640.   SpaceBefore: boolean;
  641. begin
  642.    if Str = '' then
  643.    begin
  644.       WordCnt := 0;
  645.       exit;
  646.    end;
  647.    SpaceBefore := true;
  648.    W := 0;
  649.    For  I :=  1 to length(Str) do
  650.    begin
  651.       if SpaceBefore and (Str[I] <> ' ') then
  652.       begin
  653.          W := succ(W);
  654.          SpaceBefore := false;
  655.       end else
  656.          if (SpaceBefore = false) and (Str[I] = ' ') then
  657.             SpaceBefore := true;
  658.    end;
  659.    WordCnt := W;
  660. end; { WordCnt }
  661.  
  662. function ExtractWords(StartWord,NoWords:byte;Str:string):string;
  663. var Start, finish: integer;
  664. begin
  665.    if Str = '' then
  666.    begin
  667.       ExtractWords := '';
  668.       exit;
  669.    end;
  670.    Start := LocWord(1,StartWord,Str);
  671.    if Start <> 0 then
  672.       finish := LocWord(Start,succ(NoWords),Str)
  673.    else
  674.    begin
  675.       ExtractWords := '';
  676.       exit;
  677.    end;
  678.    if finish = 0 then
  679.       finish := succ(length(Str));
  680.    repeat
  681.       finish := pred(finish);
  682.    until Str[finish] <> ' ';
  683.    ExtractWords := copy(Str,Start,succ(finish-Start));
  684. end; { ExtractWords }
  685.  
  686. function ValidInt(Str:string):boolean;
  687. {}
  688. var Temp: longint;
  689.     Code: integer;
  690.  
  691.   function NoLetters:boolean;
  692.   var I: integer;
  693.       Bad: boolean;
  694.   begin
  695.      NoLetters := true;
  696.      for I := 1 to length(Str) do
  697.      begin
  698.         if (Str[I] in ['0'..'9','+','-']) = false then  {1.00b}
  699.            NoLetters := false;
  700.      end;
  701.   end; { NoLetters }
  702.  
  703. begin
  704.    if length(Str) = 0 then
  705.       ValidInt := true
  706.    else
  707.    begin
  708.       val(Str,temp,code);
  709.       ValidInt := (Code = 0) and Noletters;
  710.    end;
  711. end; { ValidInt }
  712.  
  713. function ValidHEXInt(Str:string):boolean;
  714. {}
  715. var Temp: longint;
  716.     Code: integer;
  717. begin
  718.    if length(Str) = 0 then
  719.       ValidHEXInt := true
  720.    else
  721.    begin
  722.       val(Str,temp,code);
  723.       ValidHEXInt := (Code = 0);
  724.    end;
  725. end; { ValidHEXInt }
  726.  
  727. function IntToStr(Number:longint):string;
  728. {}
  729. var Temp: string;
  730. begin
  731.    Str(Number,temp);
  732.    IntToStr := temp;
  733. end; { IntToStr }
  734.  
  735. function IntToHEXStr(Number:longint;Width:integer):string;
  736. {}
  737. const
  738.    HEXChars: array [0..15] of char = '0123456789ABCDEF';
  739. var
  740.    I: integer;
  741.    Str: string;
  742.    BitsToShift: byte;
  743.    Chr: char;
  744. begin
  745.    Str := '';
  746.    for I := 7 downto 0 do
  747.    begin
  748.       BitsToShift := I*4;
  749.       Chr := HEXChars[ (Number shr BitsToShift) and $F];
  750.       if not ((Str = '') and (Chr = '0')) then
  751.          Str := Str + Chr;
  752.    end;
  753.    if ( Width in [1..4] ) then
  754.       IntToHEXStr := PadRight(Str,Width,'0')
  755.    else
  756.       IntToHEXStr := Str;
  757. end; { IntToHEXStr }
  758.  
  759. function ValidReal(Str:string):boolean;
  760. {}
  761. var Code: integer;
  762.     Temp: extended;
  763. begin
  764.    if length(Str) = 0 then
  765.       ValidReal := true
  766.    else
  767.    begin
  768.       if Copy(Str,1,1)='.' Then
  769.          Str:='0'+Str;
  770.       if (Copy(Str,1,1)='-') and (Copy(Str,2,1)='.') Then
  771.          Insert('0',Str,2);
  772.       if Str[length(Str)] = '.' then
  773.          Delete(Str,length(Str),1);
  774.       val(Str,temp,code);
  775.       ValidReal := (Code = 0);
  776.    end;
  777. end; { ValidReal }
  778.  
  779. function StrToReal(Str:string):extended;
  780. var code: integer;
  781.     Temp: extended;
  782. begin
  783.    if length(Str) = 0 then
  784.       StrToReal := 0
  785.    else
  786.    begin
  787.       if Copy(Str,1,1)='.' Then
  788.          Str:='0'+Str;
  789.       if (Copy(Str,1,1)='-') and (Copy(Str,2,1)='.') Then
  790.          Insert('0',Str,2);
  791.       if Str[length(Str)] = '.' then
  792.          Delete(Str,length(Str),1);
  793.       val(Str,temp,code);
  794.       if code = 0 then
  795.          StrToReal := temp
  796.       else
  797.       begin
  798.          StrSetError(1003);
  799.          StrToReal := 0;
  800.       end;
  801.    end;
  802. end; { StrToReal }
  803.  
  804. function RealToStr(Number:extended;Decimals:byte):string;
  805. var Temp: string;
  806. begin
  807.    Str(Number:20:Decimals,Temp);
  808.    repeat
  809.       if copy(Temp,1,1) = ' ' then delete(Temp,1,1);
  810.    until copy(temp,1,1) <> ' ';
  811.    if Decimals = Floating then
  812.    begin
  813.       Temp := Strip('R','0',Temp);
  814.       if Temp[length(temp)] = '.' then
  815.          Delete(temp,length(temp),1);
  816.    end;
  817.    RealToStr := Temp;
  818. end; { RealToStr }
  819.  
  820. function StrToInt(Str:string):integer;
  821. var temp,code : integer;
  822. begin
  823.    if (length(Str) = 0) or (Str = '-') or (str = '+') then
  824.       StrToInt := 0
  825.    else
  826.    begin
  827.       val(Str,temp,code);
  828.       if code = 0 then
  829.          StrToInt := temp
  830.       else
  831.       begin
  832.          StrToInt := 0;
  833.          StrSetError(1004);  { String to integer conversion error }
  834.       end;
  835.    end;
  836. end; { StrToInt }
  837.  
  838. function StrToLong(Str:string):Longint;
  839. var code: integer;
  840.     Temp: longint;
  841. begin
  842.    if length(Str) = 0 then
  843.       StrToLong := 0
  844.    else
  845.    begin
  846.       val(Str,temp,code);
  847.       if code = 0 then
  848.          StrToLong := temp
  849.       else
  850.       begin
  851.          StrToLong := 0;
  852.          StrSetError(1002) { Error converting StrToLong }
  853.       end;
  854.    end;
  855. end; { StrToLong }
  856.  
  857. function LongToFmtStr(Number:longint):string;
  858. {}
  859. var FStr: string;
  860.     DP: integer;
  861. begin
  862.    Fstr := IntToStr(Number);
  863.    DP := length(FStr) - 2;
  864.    while (DP > 1) and IsDigit(ord(FStr[pred(DP)])) do
  865.    begin
  866.       insert(ThouChr,FStr,DP);
  867.       dec(DP,3);
  868.    end;
  869.    LongToFmtStr := FStr;
  870. end; { LongToFmtStr }
  871.  
  872. function HEXStrToLong(Str:string):longint;
  873. {}
  874. begin
  875.    if Str = '' then
  876.       HEXStrToLong := 0
  877.    else
  878.    begin
  879.       if Str[1] <> '$' then
  880.          Str := '$'+Str;
  881.       HEXStrtoLong := StrToLong(Str);
  882.    end;
  883. end; { HEXStrToLong }
  884.  
  885. function Decimals (L:byte):byte;
  886. {INTERNAL}
  887. var Expnt: byte;
  888.     Temp: shortint;
  889. begin
  890. {$IFDEF FLOAT}
  891.    Expnt := 4;
  892. {$ELSE}
  893.    {$IFDEF FLOATEM}
  894.    Expnt := 4;
  895.    {$ELSE}
  896.    Expnt := 2;
  897.    {$ENDIF}
  898. {$ENDIF}
  899.    Temp := L-Expnt-5;
  900.    if temp > 0 then
  901.       Decimals := Temp
  902.    else
  903.       Decimals := 0;
  904. end; { Decimals }
  905.  
  906. function RealToSciStr(Number:extended; D:byte):string;
  907. {Credits: Michael Harris, Houston.
  908.           Peter Sands, Australia
  909.           Frans van Capelle, Amsterdam
  910.  Thanks!}
  911. Const
  912.     DamnNearUnity = 9.99999999E-01;
  913. Var
  914.     Temp : extended;
  915.     Power: integer;
  916.     Value: string;
  917.     Sign : char;
  918.     Expnt: byte;
  919. begin
  920.    if Number = 1.0 then
  921.       RealToSciStr := '1.000'
  922.    else if Number = 0.0 then
  923.       RealToSciStr := '0.000'
  924.    else
  925.    begin
  926.       Temp := Number;
  927.       Power := 0;
  928.       if abs(Number) > 1.0 then
  929.       begin
  930.          while abs(Temp) >= 10.0 do
  931.          begin
  932.             Inc(Power);
  933.             Temp := Temp/10.0;
  934.          end;
  935.          Sign := '+';
  936.       end else
  937.       begin
  938.          while abs(Temp) < DamnNearUnity do
  939.          begin
  940.             Inc(Power);
  941.             Temp := Temp * 10.0;
  942.          end;
  943.          Sign := '-';
  944.       end;
  945.       Value := RealToStr(Temp,D);
  946. {$IFDEF FLOAT}
  947.       Expnt := 4;
  948. {$ELSE}
  949.    {$IFDEF FLOATEM}
  950.       Expnt := 4;
  951.    {$ELSE}
  952.       Expnt := 2;
  953.    {$ENDIF}
  954. {$ENDIF}
  955.       RealToSciStr := Value+'E'+Sign+Padright(IntToStr(Power),Expnt,'0');
  956.    end;
  957. end; { RealToSciStr }
  958.  
  959. function NthNumber(InStr:string;Nth:byte): char;
  960. {Returns the nth number in an alphanumeric string}
  961. var
  962.    Counter: byte;
  963.    B, Len: byte;
  964. begin
  965.     Counter := 0;
  966.     B := 0;
  967.     Len := length(InStr);
  968.     repeat
  969.        Inc(B);
  970.        If InStr[B] in ['0'..'9'] then
  971.           Inc(Counter);
  972.     until (Counter = Nth) or (B = Len);
  973.     if counter = Nth then  {1.00}
  974.        NthNumber := InStr[B]
  975.     else
  976.        NthNumber := #0;
  977. end; { NthNumber }
  978.  
  979.                   {*************************************}
  980.                   {**  Case Conversion/International  **}
  981.                   {*************************************}
  982.  
  983. function CapitalWord(W:word):word;
  984. {Converts the character represented by W to uppercase and
  985.  returns the word value of the capital letter}
  986. var Ch: char;
  987. begin
  988.    if W > 255 then
  989.       CapitalWord := W
  990.    else
  991.       CapitalWord := ord(GetUpcase(char(W)));
  992. end; { CapitalWord }
  993.  
  994. function IsUpper(K:word): boolean;
  995. {}
  996. begin
  997.    if K > 255 then
  998.      IsUpper := false
  999.    else
  1000.      IsUpper := pos(chr(K),StrVars.UpperStr) > 0;
  1001. end; { IsUpper }
  1002.  
  1003. function IsLower(K:word): boolean;
  1004. {}
  1005. begin
  1006.    if K > 255 then
  1007.      IsLower := false
  1008.    else
  1009.      IsLower := pos(chr(K),StrVars.LowerStr) > 0;
  1010. end; { IsLower }
  1011.  
  1012. function IsDigit(K:word): boolean;
  1013. {}
  1014. begin
  1015.    IsDigit := chr(K) in NumSet;
  1016. end; { IsDigit }
  1017.  
  1018. function IsLetter(K:word): boolean;
  1019. {}
  1020. begin
  1021.    if K > 255 then
  1022.      IsLetter := false
  1023.    else
  1024.      IsLetter := pos(chr(K),StrVars.LowerStr+StrVars.UpperStr) > 0;
  1025. end; { IsLetter }
  1026.  
  1027. function IsPunctuation(K:word): boolean;
  1028. {}
  1029. begin
  1030.    if K > 255 then
  1031.      IsPunctuation := false
  1032.    else
  1033.      IsPunctuation := chr(K) in StrVars.PuncChars;
  1034. end; { IsPunctuation }
  1035.  
  1036. function GetUpCase(Ch:char):char;
  1037. {}
  1038. var P: byte;
  1039. begin
  1040.    P := pos(Ch,StrVars.LowerStr);
  1041.    if P = 0 then
  1042.       GetUpCase := Ch
  1043.    else
  1044.       GetUpCase := StrVars.UpperStr[P];
  1045. end; { GetUpCase }
  1046.  
  1047. function GetLoCase(Ch:char):char;
  1048. {}
  1049. var P: byte;
  1050. begin
  1051.    P := pos(Ch,StrVars.UpperStr);
  1052.    if P = 0 then
  1053.       GetLoCase := Ch
  1054.    else
  1055.       GetLoCase := StrVars.LowerStr[P];
  1056. end; { GetLoCase }
  1057.  
  1058.                           {**********************}
  1059.                           {**  Line Splitting  **}
  1060.                           {**********************}
  1061.  
  1062. function CharCount(Ch:Char;Str:String):byte;
  1063. {Returns the total number of times Ch occurs in Str}
  1064. var C,L:byte;
  1065.     I:integer;
  1066. begin
  1067.    C := 0;
  1068.    L := length(Str);
  1069.    for I := 1 to L do
  1070.       if Str[I] = Ch then
  1071.          inc(C);
  1072.     CharCount := C;
  1073. end; { CharCount }
  1074.  
  1075. function WidestLine(Str:string):byte;
  1076. {Searches for the embedded line break character and returns the
  1077.  length of the longest line-element}
  1078. var
  1079.    P,L,TempL: byte;
  1080.    TempStr: string;
  1081. begin
  1082.    P := pos(StrVars.LineBreak,Str);
  1083.    if P = 0 then
  1084.       WidestLine := length(strip('A',HiMarker,Str))
  1085.    else
  1086.    begin
  1087.       L := pred(P);
  1088.       delete(Str,1,P);
  1089.       while Str <> '' do
  1090.       begin
  1091.          P := pos(StrVars.LineBreak,Str);
  1092.          if P = 0 then
  1093.          begin
  1094.             TempL := length(strip('A',HiMarker,Str));
  1095.             if TempL > L then
  1096.                L := TempL;
  1097.             Str := '';
  1098.          end else
  1099.          begin
  1100.             TempStr := copy(Str,1,pred(P));
  1101.             delete(Str,1,P);
  1102.             TempL := length(strip('A',HiMarker,TempStr));
  1103.             if TempL > L then
  1104.                L := TempL;
  1105.          end;
  1106.       end;
  1107.       WidestLine := L;
  1108.    end;
  1109. end; { WidestLine }
  1110.  
  1111. function LineCount(Str:string):byte;
  1112. {}
  1113. var P: byte;
  1114. begin
  1115.    P := pos(StrVars.LineBreak,Str);
  1116.    if P = 0 then
  1117.       LineCount := 1
  1118.    else
  1119.       LineCount := succ(CharCount(StrVars.LineBreak,Str));
  1120. end; { LineCount }
  1121.  
  1122.                         {**************************}
  1123.                         {**  Encryption Methods  **}
  1124.                         {**************************}
  1125.  
  1126. function DeCode(Str: string): string;
  1127. {}
  1128. var Ch: byte;
  1129.     I,L: integer;
  1130.     TempStr: string;
  1131. begin
  1132.    with StrVars do
  1133.    begin
  1134.       L := length(Str);
  1135.       if L > 0 then
  1136.       begin
  1137.          for I := 1 to L do
  1138.          begin
  1139.             Ch := EncryptionCode XOR ord(Str[I]);
  1140.             TempStr[I] := chr(Ch);
  1141.          end;
  1142.          TempStr[0] := Str[0];
  1143.          DeCode := TempStr;
  1144.       end else
  1145.          DeCode := '';
  1146.    end;
  1147. end; { DeCode }
  1148.  
  1149. function EnCode(Str: string): string;
  1150. {}
  1151. var Ch: byte;
  1152.     I,L: integer;
  1153.     TempStr: string;
  1154. begin
  1155.    with StrVars do
  1156.    begin
  1157.       L := length(Str);
  1158.       if L > 0 then
  1159.       begin
  1160.          for I := 1 to L do
  1161.          begin
  1162.             Ch := EncryptionCode XOR ord(Str[I]);
  1163.             TempStr[I] := chr(Ch);
  1164.          end;
  1165.          TempStr[0] := Str[0];
  1166.          EnCode := TempStr;
  1167.       end else
  1168.          EnCode := '';
  1169.    end;
  1170. end; { EnCode }
  1171.  
  1172.               {*********************************************}
  1173.               {**  U N I T   I N I T I A L I Z A T I O N  **}
  1174.               {*********************************************}
  1175. procedure StrDefaultSettings;
  1176. {}
  1177. begin
  1178.    with StrVars do
  1179.    begin
  1180.       { it is much safer to keep the encryption code
  1181.         between 128 and 255.  Values between 0 and 127
  1182.         ocassionally produce a Ctrl-Z or EOF character.
  1183.         This produces a premature end-of-file.  }
  1184.       EncryptionCode := 134;
  1185.       LowerStr := 'abcdefghijklmnopqrstuvwxyz';
  1186.       UpperStr := 'ABCDEFGHIJKLMNOPQRSTUVWXYZ';
  1187.       PuncChars := [',',';',':','.',' '];
  1188.       LineBreak := '|';
  1189.       TabBreak := '|';
  1190.       SqzChars := '..';
  1191.       SuppressErrors := false;
  1192.    end;
  1193. end; { StrDefaultSettings }
  1194.  
  1195. procedure GoldStrInit;
  1196. {}
  1197. begin
  1198.    with StrVars do
  1199.    begin
  1200.       Ecode := 0;
  1201.       EMsgFunc := StrEMsg;
  1202.    end;
  1203.    StrDefaultSettings;
  1204. end; { GoldStrInit }
  1205.  
  1206. {$IFDEF TTT5}
  1207.  
  1208. function Str_to_Int(Str:string):integer;
  1209. {included for TTT5 compatibility}
  1210. begin
  1211.    Str_To_Int := StrToInt(Str);
  1212. end; { Str_To_Int }
  1213.  
  1214. function Str_to_Long(Str:string):Longint;
  1215. {included for TTT5 compatibility}
  1216. begin
  1217.    Str_To_Long := StrToLong(Str);
  1218. end; { Str_To_Long }
  1219.  
  1220. function Str_to_Real(Str:string):real;
  1221. {included for TTT5 compatibility}
  1222. begin
  1223.    Str_To_Real := StrToReal(Str);
  1224. end; { Str_To_Long }
  1225.  
  1226. function Real_to_str(Number:real;Decimals:byte):string;
  1227. {included for TTT5 compatibility}
  1228. begin
  1229.    Real_To_Str := RealToStr(Number,Decimals);
  1230. end; { Real_To_Str }
  1231.  
  1232. function Int_to_Str(Number:longint):string;
  1233. {included for TTT5 compatibility}
  1234. begin
  1235.    Int_To_Str := IntToStr(Number);
  1236. end; { Int_To_Str }
  1237.  
  1238. function Real_to_SciStr(Number:real; D:byte):string;
  1239. {included for TTT5 compatibility}
  1240. begin
  1241.    Real_To_SciStr := RealToSciStr(Number,D);
  1242. end; { Real_to_SciStr }
  1243.  
  1244. {$ENDIF}
  1245.  
  1246. begin
  1247.    GoldStrInit;
  1248. end.
  1249.