hyperstr.pas

String hanlding library. Functions for crypto, token etc

procedure IniSQZ;
function  SQZ(const Bfr:AnsiString; L:Word):AnsiString;
function  UnSQZ(const Bfr:AnsiString; L:Word):AnsiString;
function  BPE(const Bfr:AnsiString; L:Word):AnsiString;
function  BPD(const Bfr:AnsiString; L:Word):AnsiString;

//Communicate
function  ListComm:AnsiString;
function  OpenComm(const Mode:AnsiString):THandle;
function  ReadComm(const pHnd:THandle; var Bfr:AnsiString):Integer;
function  WriteComm(const pHnd:THandle; const Bfr:AnsiString):Integer;
function  StatusComm(const pHnd:THandle):Integer;
function  CloseComm(const pHnd:THandle):Boolean;
function  GetComm(const pHnd:THandle):Char;
function  SetRxTime(const pHnd:THandle; const TimeC,TimeM:Integer):Boolean;
function  ModemThere(const pHnd:THandle):Boolean;
function  ModemCommand(const pHnd:THandle; S:AnsiString):Boolean;
function  ModemResponse(const pHnd:THandle):AnsiString;
function  ModemDialog:Boolean;
function  OpenSlot(const Name:AnsiString):THandle;
function  ReadSlot(const hSlot:THandle;var Bfr:AnsiString):Boolean;
function  WriteSlot(const Name,Bfr:AnsiString):Boolean;
function  CloseSlot(const hSlot:THandle):Boolean;
function  MakePipe(const Name:AnsiString):THandle;
function  OpenPipe(const Name:AnsiString):THandle;
function  StartPipe(const hPipe:THandle):Boolean;
function  StopPipe(const hPipe:THandle):Boolean;
function  RecvPipe(const hPipe:THandle;var Bfr:AnsiString):Boolean;
function  SendPipe(const hPipe:THandle;Bfr:AnsiString):Boolean;
function  StatusPipe(const hPipe:THandle):Integer;
function  KillPipe(const hPipe:THandle):Boolean;

//Miscellaneous
function  UnSignedCompare(const X,Y:Integer):Boolean;
function  LoBit(const X:Integer):Integer;
function  HiBit(const X:Integer):Integer;
function  RotL(const X,Cnt:Integer):Integer;
function  RotR(const X,Cnt:Integer):Integer;
function  TestBit(const X,Cnt:Integer):Boolean;
procedure SetBit(var X:Integer;Cnt:Byte);
procedure ClrBit(var X:Integer;Cnt:Byte);
function  CntBit(X:Integer):Integer;
procedure SetByteBit(var X:Byte;Cnt:Byte);
procedure ClrByteBit(var X:Byte;Cnt:Byte);
procedure IntSwap(var I1,I2:Integer);
procedure WordSwap(var W1,W2:Word);
//The two below are undocumented
function  SetFileLock(const FHandle,LockStart,LockSize:Integer):Boolean;
function  ClrFileLock(const FHandle,LockStart,LockSize:Integer):Boolean;
//The two above are undocumented
function  RndToFlt(const X:Double):Double;
function  RndToInt(const X:Double):Integer;
function  RndToDec(const X:Double; Decimals:Integer):Double;
function  TruncToDec(const X:Double; Decimals:Integer):Double;
function  RndToSig(const X:Double; Digits:Integer):Double;
function  RndToCents(const X:Currency):Currency;
function  TruncToCents(const X:Currency):Currency;
function  RndToSecs(const DT:TDateTime;Secs:Word):TDateTime;
function  FloatToFrac(const X : Double; D:Integer) : AnsiString;
procedure SetFloatTolerance(X:Double);
function  CmpFloat(X,Y:Double):Integer;
function  IPower(const X,Y:Integer):Integer;
function  IPower2(const Y:Integer):Integer;
function  iMin(const I,J:Integer):Integer;
function  iMax(const I,J:Integer):Integer;
function  iMid(const I,J,K:Integer):Integer;
function  iRnd(const Value,Range:Integer):Integer;
function  iTrunc(const Value,Range:Integer):Integer;
function  iSign(const Value:Integer):Integer;
function  Sign(const I:Variant):Integer;
function  SignDbl(const D:Double):Integer;
function  GCD(const X,Y:DWord):DWord;
//The three below are undocumented
function  LRC(const Source:AnsiString):Char;
function  InPort(Address:Word):Byte;
procedure OutPort(Data:Byte;Address:Word);
//The three above are undocumented
function  CalcStr(Source:AnsiString):Double;
function  UniqueApp(const Title:AnsiString):Boolean;
procedure SpeakerBeep;
procedure Marquee(var S:AnsiString);
function  GetNICAddr:AnsiString;
function  iif(const Condition: Boolean; Value1, Value2: Variant): Variant;
function  StateAbbrev(S:AnsiString):AnsiString;
function  DriveNum(DriveLtr:Char):Byte;
procedure AddSlash(var Path:AnsiString);
procedure DelSlash(var Path:AnsiString);
function  RomanNum(Number:Integer):AnsiString;
function  ASC2HTM(Title,Text,Attributes:AnsiString):AnsiString;
function  IsConsole:Boolean;
function  IsDebugger:Boolean;
function  WinstallDate:AnsiString;
function  GetDigit(Value,N:Integer):Integer;
function  RandomText(L:Integer; Table:AnsiString):AnsiString;

implementation

uses NB30;

{The following global data is used and abused throughout this unit. This is
 generally not very good practice as it can lead to some very subtle bugs.
 However, this unit is (or at least should be) a controlled, self contained
 environment. This data adds insignificant overhead to an app using HyperString.}
type
  CodeType      = 0..256;         //Word
  UpIndex       = 0..255;         //Byte
  DownIndex     = 0..512;        //Word
  TStates       = array[0..50] of Integer;
  TAbbrev       = array[0..50] of Word;
  TMask         = array[0..31] of Byte;  //generic bit mapped character table
  TreeDownArray = array[UpIndex]   of DownIndex;
  TreeUpArray   = array[DownIndex] of UpIndex;
  TStdIO = record
    hRead, hWrite : DWORD;
  end;

const
  BufSize  = 65536;                //Max. compression work buffer
  MaxChar  = 256;                  //Ordinal of highest character
  PredMax  = 255;                  //MaxChar-1
  TwiceMax = 512;                  //2*MaxChar
  Ticks    = 1440;                 //Integer Date/Time constant
  B64Tbl:ShortString='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=';
  DUPLICATE_CLOSE_SOURCE = 1;
  DUPLICATE_SAME_ACCESS  = 2;

  States: TStates = ( //MetaPhone table of US state names
  1095516749,1095521099,1095912270,1095914318,1179406932,1179798862,1179799072,
  1213669408,1229737555,1229870158,1230250016,1230446624,1263289938,1263293012,
  1263422292,1263424339,1263424587,1280855584,1296965664,1296978772,1296979022,
  1297239118,1297306144,1297306448,1297307731,1297632800,1312969299,1313231904,
  1313361232,1313493587,1313688403,1314009163,1314009172,1314476619,1330126880,
  1330334797,1330794016,1347310412,1377837088,1380471891,1395673938,1395676235,
  1414222675,1414289234,1414419232,1414747218,1431586848,1465076558,1465078854,
  1465405003,1498238539);

  Abbrev: TAbbrev = ( //abbreviations corresponding to above
  16716,16715,16722,16730,17996,22100,22081,18505,18764,18766,18756,18753,
  17217,17231,17236,19283,19289,19521,19781,19790,19796,19780,19791,19795,
  19777,19785,20037,20054,20040,20042,20045,20035,20036,20057,20296,20299,
  20306,20545,18241,21065,21315,21316,21592,17477,21582,17475,21844,22345,
  22358,22337,22361);

  NumT:TMask = (0,0,0,0,1,0,255,3,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
  HexT:TMask = (0,0,0,0,0,0,255,3,126,0,0,0,126,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
  OK = 'OK';
  CLOSURE = '*';    // match zero or more of preceding character
  BOL = '^';        // beginning of line
  EOL = '$';        // end of line
  ESCAPE = '\';     // escape next character
  DASH = '-';       // used in [a-z] type expressions
  NEGATE = '^';     // negate next character/range in [a-z] expression
  CCL ='[';         // intro for [a-z] expressions
  CCLEND = ']';     // outro for [a-z] expressions
  ANY = '.';        // match any single character
  //internal tokens
  NCCL = '!';       // negate [a-z] must not be same as NEGATE!!!
  LITCHAR = '@';    // quote single literal character
  TAB = #9;         // tab
  cwChop:Word = $1F32;
  cwDown:Word = $177F;
  Cents :DWord=100;
var
  S     : TStartupInfo;
  P     : TProcessInformation;
  iScan : TMask;
  SInn  : TStdIO;
  SOut  : TStdIO;
  XI    : TLargeInteger;
  Left  : TreeDownArray;
  Right : TreeDownArray;
  Up    : TreeUpArray;
  AA    : DownIndex;
  bScan   : Boolean=True;
  bPipe   : Boolean=False;
  BfrFlg  : Boolean=False;
  RLEFlg  : Boolean=False;
  hMutex  : THandle = 0;
  Delimiter : Char = ',';
  Delimiter2: AnsiString=','#0;
  DecSep    : Char = #0;
  TimeSep   : Char = #0;
  DateSep   : Char = #0;
  ThouSep   : Char = #0;
  cC        : Char = #0;
  QS        : Char = #34;
  QE        : Char = #34;
  iStack : array [0..127] of Integer;
  RCA    : array [0..64] of Integer;
  bI,bJ,bX:Boolean;
  dwI,dwJ,dwK,dwL:DWord;
  dI:Double;
  wI,RCS:Word;
  iMn,iMx,iTry,OutLen,Stcknum,Total,L1,R1,L2,R2,Score,s2ed:Integer;
  RevCase:array[0..255] of Char;      //character conversion tables
  LowCase:array[0..255] of Char;
  UprCase:array[0..255] of Char;
  LowT,UprT,AlphaT,AlphaNumT,VowelT:TMask;   //set tables
  FloatTolerance:Double=1.0e-9;              //floating point comparison



function GetRefCnt(Source:AnsiString):Integer;
  {Retrieve the reference count for a string.  Mainly for internal use.}
asm
  Or   EAX,EAX
  Jz   @Exit
  Mov  EAX,[EAX-8]
@Exit:
end;

procedure GetSeps;
var
  I,J,K:Integer;
  Buffer: array[0..1] of Char;
  Locale: LCID;
begin
  Locale := GetThreadLocale;
  if GetLocaleInfo(Locale, LOCALE_SDECIMAL, Buffer, 2) > 0 then
    DecSep:=Buffer[0] else DecSep:='.';
  if GetLocaleInfo(Locale, LOCALE_STIME, Buffer, 2) > 0 then
    TimeSep:=Buffer[0] else TimeSep:=':';
  if GetLocaleInfo(Locale, LOCALE_SDATE, Buffer, 2) > 0 then
    DateSep:=Buffer[0] else DateSep:='/';
  if GetLocaleInfo(Locale, LOCALE_STHOUSAND, Buffer, 2) > 0 then
    ThouSep:=Buffer[0] else ThouSep:=',';
  for I:=0 to 31 do begin
    AlphaT[I]:=0;
    LowT[I]:=0;
    UprT[I]:=0;
  end;
  for I:=0 to 255 do begin  //build default ASCII case tables
    RevCase[I]:=Char(I);
    LowCase[I]:=Char(I);
    UprCase[I]:=Char(I);
    K:=I AND 7;
    J:=I SHR 3;
    if (I>=65) AND (I<=90) then begin
      LowCase[I]:=Char(I XOR 32);
      RevCase[I]:=LowCase[I];
      SetByteBit(AlphaT[J],K);
      SetByteBit(UprT[J],K);
    end else if (I>=97) AND (I<=122) then begin
      UprCase[I]:=Char(I XOR 32);
      RevCase[I]:=UprCase[I];
      SetByteBit(AlphaT[J],K);
      SetByteBit(LowT[J],K);
    end;
  end;
  AlphaT[4]:=1; //include space character
  for I:=0 to 31 do AlphaNumT[I]:=AlphaT[I] OR NumT[I];  //combine these two
end;


function SetStrAddr(Addr:DWord):AnsiString;
  {Sets resultant string to point to a specific null terminated string address.}
begin
  Result:=AnsiString(PChar(Ptr(Addr)));
end;


function  SetCaseTable(const Lower,Upper:AnsiString):Boolean;
  {Sets internal case conversion and set tables}
var
  I,J:Integer;
  K:Byte;
begin
  Result:=False;
  if Length(Lower)=0 then Exit;
  if Length(Lower)=Length(Upper) then begin
    for I:=0 to 31 do begin
      AlphaT[I]:=0;
      LowT[I]:=0;
      UprT[I]:=0;
    end;
    for I:=0 to 255 do begin
      LowCase[I]:=Char(I);
      UprCase[I]:=Char(I);
      RevCase[I]:=Char(I);
    end;
    for I:=1 to Length(Lower) do begin
      J:=Ord(Lower[I]);
      RevCase[J]:=Upper[I];
      UprCase[J]:=Upper[I];
      K:=J AND 7;
      J:=J SHR 3;
      SetByteBit(AlphaT[J],K);
      SetByteBit(LowT[J],K);
    end;
    for I:=1 to Length(Upper) do begin
      J:=Ord(Upper[I]);
      RevCase[J]:=Lower[I];
      LowCase[J]:=Lower[I];
      K:=J AND 7;
      J:=J SHR 3;
      SetByteBit(AlphaT[J],K);
      SetByteBit(UprT[J],K);
    end;
    AlphaT[4]:=1;  //include space
    for I:=0 to 31 do AlphaNumT[I]:=AlphaT[I] OR NumT[I];
    Result:=True;
  end;
end;


procedure  SetVowelTable(const Vowels:AnsiString);
  {Sets internal table with vowel characters}
var
  I,J:Integer;
  K:Byte;
begin
  if Length(Vowels)>0 then begin
    for I:=0 to 31 do VowelT[I]:=0;
    for I:=1 to Length(Vowels) do begin
      J:=Ord(Vowels[I]);
      K:=J AND 7;
      J:=J SHR 3;
      SetByteBit(VowelT[J],K);
    end;
  end;
end;


function Compact(var Source:AnsiString):Integer;

  {Compact a string by moving embedded spaces and control char. to
   the right where they can be deleted if necessary using RTrim or
   SetLength.

   Returns: Length minus #chars. moved and converted to spaces.}

  asm
    Push  ESI
    Push  EDI             //save the important stuff
    Push  EBX

    Xor   EBX,EBX
    Or    EAX,EAX
    Jz    @Done
    Push  EAX
    Call  UniqueString
    Pop   EAX
    Mov   ESI,[EAX]       //get Source address in read register
    Or    ESI,ESI
    Jz    @Done
    Mov   EDI,ESI         //...and write register
    Mov   ECX,[ESI-4]     //get length into count register
    Mov   EBX,ECX         //save it in EBX
    Jecxz @Done           //bail out if zero length
    Mov   DL,32           //looking for spaces (or less)
    Cld                   //make sure we go forward
@L1:
    Lodsb
    Cmp   AL,DL           //space or less?
    Jbe   @L2             //yes, then skip the write
    Stosb
@L2:
    Dec   ECX
    Jnz   @L1
    Mov   AL,DL
@L3:
    Cmp   ESI,EDI         //read = write ?
    Jz    @Done           //yes, then we're done
    Stosb                 //otherwise, pad with a space
    Dec   EBX             //decrease the length
    Jmp   @L3             //and do it again
@Done:
    Mov   Result,EBX      //set output length

    Pop   EBX
    Pop   EDI             //restore the important stuff
    Pop   ESI
  end;                    //and we're outta here


procedure LCompact(var Source:AnsiString);

  {Compact a string by moving embedded spaces and control char. to
   the left.}