// **********************************************************************
// Use Strings.nui  // String manipulation for VDF (No User Interface)
//
// By Sture Andersen
//
// The file contains a number of global functions for manipulating
// strings and converting numbers to strings. The package may be used
// with DataFlex 3.2 and Visual DataFlex. This package is public domain.
//
//
// Create: Fri  23-05-1997 - Merger of s_utl002, 006.
// Update: Tue  25-08-1997 - Fixes by Magnus Bergh
//         Sun  14-12-1997 - Added the following functions:
//                             ExtractWord           ExtractInteger
//                             HowManyWords          HowManyIntegers
//                             ExtractItemNeg        IsIntegerPresent
//         Tue  31-03-1998 - Added the following functions:
//                             Text_RemoveTrailingCr Text_CompressSubstCr
//                             Text_RTrim            Text_Format.sii
//                             Text_Trim             Text_FormattedLine.i
//                             Text_Compress
//         Fri  06-11-1998 - Added function InsertThousandsSep
//         Sun  14-02-1999 - Added function Byte_ToHex
//         Wed  27-04-1999 - Added function CurrentDecimalSeparator
//         Mon  08-11-1999 - Added procedure Text_SetEditObjectValue and
//                           function Text_EditObjectValue
//         Mon  22-11-1999 - Function Text_RemoveTrailingCr strengthened
//         Wed  01-12-1999 - Function StringFieldType added
//         Wed  12-01-2000 - Functions StringOemToAnsi and StringAnsiToOem
//                           added when compiled using the Windows compiler
//         Wed  17-05-2000 - Function NumToStr fixed for use with VDF 6.0.
//         Mon  29-05-2000 - Attempt to fix function Text_EditObjectValue
//         Fri  21-07-2000 - InsertThousandsSep fixed for use with negative
//                           numbers.
//                         - Functions IntToStrRTS, NumToStrRTS and NumToStrTS
//                           added.
//         Fri  25-08-2000 - Function NumToStrRzf added
//         Wed  28-02-2001 - Add function OldHexToByte, renamed existing function
//                           Byte_ToHex to OldByteToHex
//         Mon  19-03-2001 - Functions StringBeginsWith and StringEndsWith
//                           added
//         Thu  19-07-2001 - StringIsInteger added
//         Sat  05-04-2002 - Global strings str.Chr10 and str.Chr1013 added.
//         Tue  04-06-2002 - Oem to ANSI and vice versa for DF3.2 UNIX/DOS/LINUX
//         Tue  09-09-2003 - Function StringFieldText added
//         Tue  18-01-2005 - Function String_NegateSortOrder added
//         Mon  14-03-2005 - Functions StringHead and StringTail added
//         Sun  12-11-2006 - Functions renamed: ByteToHex     -> vdfq_ByteToHex
//                                              HexToByte     -> vdfq_HexToByte
//                                              StringToHex   -> vdfq_StringToHex
//                                              HexToString   -> vdfq_HexToString
//                                              WildCardMatch -> vdfq_WildCardMatch
//
//
//
// ***********************************************************************

use ui
Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes

// Returns the string of length len# inside which src# is right justified:
Function RightShift global string src# integer len# returns string
  trim src# to src#
  if (length(src#)) lt len# insert (left(pad("",len#),len#-length(src#))) in src# at 1
  function_return (left(src#,len#))
End_Function

// Returns the string of length len# inside which src# is centered:
Function CenterString global string src# integer len# returns string
  trim src# to src#
  if (length(src#)) lt len# insert (left(pad("",len#),len#-length(src#)/2)) in src# at 1
  function_return (left(src#,len#))
End_Function

// Returns all characters to the right of position pos# (including the character at
// posistion pos#)
Function RightFromPos global string str# integer pos# returns string
  function_return (right(str#,length(str#)-pos#+1))
End_Function

// Number converting functions:

#REPLACE NUMTOSTR_THOUSANDS_SEPARATOR_OFF 0
#REPLACE NUMTOSTR_THOUSANDS_SEPARATOR_ON  1
integer NumToStringConversionMode#

string str.Chr10   1
string str.Chr13   1
string str.Chr1013 2
move (character(13)) to str.Chr13
move (character(10)) to str.Chr10
move (character(10)+character(13)) to str.Chr1013

move NUMTOSTR_THOUSANDS_SEPARATOR_OFF to NumToStringConversionMode#
procedure set pNumToStringConversionMode global integer value#
  move value# to NumToStringConversionMode#
end_procedure
function pNumToStringConversionMode global returns integer
  function_return NumToStringConversionMode#
end_function

function InsertThousandsSep global string str# returns string
  integer pos# tmp# neg#
  string sep#
  trim str# to str#
  move (left(str#,1)="-") to neg#
  if neg# get StringRightBut str# 1 to str#
  get_attribute DF_DECIMAL_SEPARATOR to pos#
  character pos# to sep#
  move (pos(sep#,str#)) to pos#
  ifnot pos# move (length(str#)+1) to pos#
  get_attribute DF_THOUSANDS_SEPARATOR to tmp#
  character tmp# to sep#
  while pos# gt 4
    move (pos#-3) to pos#
    insert sep# in str# at pos#
  loop
  if neg# move ("-"+str#) to str#
  function_return str#
end_function

// Calling the function below will convert the number stored in src# to a
// string containing dcp# decimals rounding excess decimals. Parameter dcp#
// may be negative. The expression (NumToStr(1789,-3)) will evaluate to "2000".
// The functions in this package all respects the value of global attribute
// DF_DECIMAL_SEPARATOR.
Function NumToStr global number src# integer dcp# returns string
  integer pos#
  number correction#
  string rval# radix#
  if dcp# lt 0 function_return (NumToStr(src#*(10^dcp#),0)+left("00000000",-dcp#))
  move (0.5/(10^dcp#)) to correction#
//    move (0.5/(10^dcp#)+src#) to src# // This does not always work with VDF 6.x!!!
  if src# ge 0 move (correction#+src#) to src#
  else move (src#-correction#) to src#
  get_attribute DF_DECIMAL_SEPARATOR to pos# // Overload
  character pos# to radix# // End overload
  move src# to rval#
  ifnot (pos(radix#,rval#)) append rval# radix#
  append rval# "00000000"
  move (pos(radix#,rval#)) to pos#
  if dcp# eq 0 decrement pos#
  move (left(rval#,pos#+dcp#)) to rval#
  if NumToStringConversionMode# move (InsertThousandsSep(rval#)) to rval#
  function_return rval#
End_Function

// This function is the same as NumToStr except that you have to specify
// the length of the target string (len#). The number will be right
// justified accordingly. Post-fix `R' means right justify:
Function NumToStrR global number src# integer dcp# integer len# returns string
  function_return (RightShift(NumToStr(src#,dcp#),len#))
End_Function

// Function NumToStrTS is the same as NumToStr except that thousand
// separators are inserted. (TS=Thousand Separator)
Function NumToStrTS global number src# integer dcp# returns string
  integer Org#
  string rval#
  move NumToStringConversionMode# to org#
  move NUMTOSTR_THOUSANDS_SEPARATOR_ON to NumToStringConversionMode#
  move (NumToStr(src#,dcp#)) to rval#
  move org# to NumToStringConversionMode#
  function_return rval#
End_Function

Function IntToStrTS global number src# returns string
  function_return (NumToStrTS(src#,0))
End_Function

Function NumToStrRTS global number src# integer dcp# integer len# returns string
  function_return (RightShift(NumToStrTS(src#,dcp#),len#))
End_Function

// This function is the same as NumToStrR except that you do not specify
// the number of decimals:
Function IntToStrR global number src# integer len# returns string
  function_return (NumToStrR(src#,0,len#)) // Fixed, Magnus Bergh
End_Function

// Same as IntToStrR (TS=Thousand Separator)
Function IntToStrRTS global number src# integer len# returns string
  function_return (NumToStrRTS(src#,0,len#))
End_Function

// Is the same as IntToStrR, except that leading blanks are substituted
// for leading zeros (zf=zero fill):
Function IntToStrRzf global number src# integer len# returns string
  function_return (replaces(" ",NumToStrR(src#,0,len#),"0")) // Fixed, Magnus Bergh
End_Function

Function NumToStrRzf global number src# integer dcp# integer len# returns string
  function_return (replaces(" ",NumToStrR(src#,dcp#,len#),"0"))
End_Function

// Use this to obtain the number of the least significant "non zero
// decimal in src#. 0.702 will return 3 while 100 will return -2:
Function NumberOfDecs global number src# returns integer
  integer count#
  string tmp# radix#
  if src# eq 0 function_return 0 // Special case
  move src# to tmp# // This removes superflous decimals
  get_attribute DF_DECIMAL_SEPARATOR to count# // Overload
  character count# to radix# // End overload
  if radix# in src# function_return (length(tmp#)-pos(radix#,tmp#))
  move 0 to count#
  while (right(tmp#,1)="0")
    move (left(tmp#,length(tmp#)-1)) to tmp#
    decrement count#
  end
  function_return count#
End_Function

Function CurrentDecimalSeparator global returns string
  integer rval#
  get_attribute DF_DECIMAL_SEPARATOR to rval#
  function_return (character(rval#))
End_Function

Procedure Set CurrentDecimalSeparator global string value#
  set_attribute DF_DECIMAL_SEPARATOR to (ascii(value#))
End_Procedure


// StripFromLastOccurance takes two strings (src# and val#) as
// arguments. src# is scanned backwards for occurrances of substring
// val#. If found, the function will return a string equal to src#
// truncated at the first character of the right most occurance of substring
// val#.
//
// StripFromLastOccurance("To be or not to be...","be") = "To be or not to "
// StripFromLastOccurance("Mary had a little lamb","white") = ""
// StripFromLastOccurance("Mary had a little lamb","") = "Mary had a little lamb"
//
Function StripFromLastOccurance global string src# string val# returns string
  integer len# search_len#
  string tmp#
  length val# to search_len#
  if search_len# eq 0 function_return src#
  repeat
    length src# to len#
    if len# le search_len# function_return ""
    move (right(src#,search_len#)) to tmp#
    if tmp# eq val# function_return (left(src#,len#-search_len#))
    move (left(src#,len#-1)) to src#
  loop
End_Function

Function GetFromLastOccurance global string src# string val# returns string
  function_return (replace(StripFromLastOccurance(src#,val#),src#,""))
End_Function

// (ExtractWord("item1 item2"," ",0)) = ""
// (ExtractWord("item1 item2"," ",1)) = "item1"
// (ExtractWord("item1 item2"," ",2)) = "item2"
// (ExtractWord("item1 item2"," ",3)) = ""
// (ExtractWord(" item1 item2 "," ",x)) =
//                       (ExtractWord("item1 item2"," ",x))
//
                         //        source     delimiters  item number
Function ExtractWord global string src# string dlm# integer itm# returns string
  integer count# pos# in_item# len#
  string rval# atom#
  move "" to rval#
  move 0 to count#
  move 0 to in_item#
  move (length(src#)) to len#
  for pos# from 1 to len#
    mid src# to atom# 1 pos#
    if in_item# begin
      if atom# in dlm# move 0 to in_item#
      else if count# eq itm# append rval# atom#
    end
    else begin
      ifnot atom# in dlm# begin
        increment count#
        move 1 to in_item#
        if count# eq itm# move atom# to rval#
      end
    end
  loop
  function_return rval#
End_Function

Function ExtractItem global string src# string dlm# integer itm# returns string
  Function_Return (ExtractWord(src#,dlm#,itm#))
End_Function
                          //        source     delimiters
Function HowManyWords global string src# string dlm# returns integer
  integer count# pos# in_item# len#
  string atom#
  move 0 to count#
  move 0 to in_item#
  move (length(src#)) to len#
  for pos# from 1 to len#
    mid src# to atom# 1 pos#
    if in_item# begin
      if atom# in dlm# move 0 to in_item#
    end
    else begin
      ifnot atom# in dlm# begin
        increment count#
        move 1 to in_item#
      end
    end
  loop
  function_return count#
end_function
Function HowManyItems global string src# string dlm# returns integer
  function_return (HowManyWords(src#,dlm#))
end_function

Function ExtractWord2 global string src# string dlm# integer itm# returns string
  integer count# pos# len#
  string rval# char#
  move "" to rval#
  move 1 to count#
  move (length(src#)) to len#
  for pos# from 1 to len#
    mid src# to char# 1 pos#
    if char# in dlm# begin
      if itm# eq count# function_return rval#
      increment count#
    end
    else if itm# eq count# move (rval#+char#) to rval#
  loop
  function_return rval#
End_Function
                          //        source     delimiters
Function HowManyWords2 global string src# string dlm# returns integer
  integer count# pos# len#
  string char#
  move 1 to count#
  move (length(src#)) to len#
  for pos# from 1 to len#
    mid src# to char# 1 pos#
    if char# in dlm# increment count#
  loop
  function_return count#
end_function
                            //        source     legal char  item number
Function ExtractItemNeg global string src# string lch# integer itm# returns string
  integer count# pos# in_item# len#
  string rval# atom#
  move "" to rval#
  move 0 to count#
  move 0 to in_item#
  move (length(src#)) to len#
  for pos# from 1 to len#
    mid src# to atom# 1 pos#
    if in_item# begin
      ifnot atom# in lch# move 0 to in_item#
      else if count# eq itm# append rval# atom#
    end
    else begin
      if atom# in lch# begin
        increment count#
        move 1 to in_item#
        if count# eq itm# move atom# to rval#
      end
    end
  loop
  function_return rval#
end_function

// ExtractInteger("123 456 789",0) = 0
// ExtractInteger("123 456 789",2) = 456
// ExtractInteger("123 456 789",4) = 0

function ExtractInteger global string str# integer itm# returns integer
  function_return (integer(ExtractItemNeg(str#,"0123456789",itm#)))
end_function

function HowManyIntegers global string str# returns integer
  integer rval# pos# len# in_int#
  move 0 to in_int# //in integer?
  move 0 to rval#
  move (length(str#)) to len#
  for pos# from 1 to len#
    if (mid(str#,1,pos#)) in "0123456789" begin
      ifnot in_int# begin
        increment rval#
        move 1 to in_int#
      end
    end
    else if in_int# move 0 to in_int#
  loop
  function_return rval#
end_function

function IsIntegerPresent global string str# integer int# returns integer
  integer max# itm#
  if str# eq "" function_return 0
  move (HowManyIntegers(str#)) to max#
  for itm# from 1 to max#
    if (ExtractInteger(str#,itm#)=int#) function_return 1
  loop
  function_return 0
end_function

function AddIntegerToString global string str# integer int# returns string
  function_return (trim(str#+" "+string(int#)))
end_function

// This function is used to compose a new string from an existing string. This
// is similar to the way Windows 95 generates 8.3 file names.

//    For example:    StringIncrementId("STURE",8) = "STURE ~1"
//                    StringIncrementId("STURE ~1",8) = "STURE ~2"
//                    StringIncrementId("STURE ~2",8) = "STURE ~3"
//                    etc...
function StringIncrementId global string id# integer len# returns string
  string char#
  if (mid(id#,1,len#-1)) eq "~" begin
    move (mid(id#,1,len#)) to char#
    if (ascii(char#)) lt 93 function_return (overstrike(character(ascii(char#)+1),id#,len#))
    else function_return ""
  end
  function_return (overstrike("~1",id#,len#-1))
end_function

function StringUppercaseFirstLetters global string str# returns string
  integer len# pos# in_word#
  string rval# char#
  move (lowercase(str#)) to str#
  move (length(str#)) to len#
  move 0 to in_word#
  for pos# from 1 to len#
    move (mid(str#,1,pos#)) to char#
    if char# eq "" move 0 to in_word#
    else begin
      ifnot in_word# begin
        uppercase char# to char#
        move 1 to in_word#
      end
    end
    move (rval#+char#) to rval#
  loop
  function_return rval#
end_function

function StringLeftBut global string str# integer but# returns string
  function_return (left(str#,length(str#)-but# max 0))
end_function

function StringRightBut global string str# integer but# returns string
  function_return (right(str#,length(str#)-but# max 0))
end_function

//> This function returns 1 if lsString is an integer and 2 if it
//> is a number (the function does not currently handle thousand seps)
function StringIsNumber global string lsString integer liDecSep returns integer
  integer liLen liPos liDecSepFound liRval
  string lsChar
  move 1 to liRval
  move 0 to liDecSepFound
  move (trim(lsString)) to lsString
  if (left(lsString,1)="-") move (replace("-",lsString,"")) to lsString
  move (length(lsString)) to liLen
  for liPos from 1 to liLen
    move (mid(lsString,1,liPos)) to lsChar
    if (ascii(lsChar)) eq liDecSep begin
      if liDecSepFound function_return 0
      move 1 to liDecSepFound
    end
    else ifnot ("0123456789" contains lsChar) function_return 0
  loop
  function_return liRval
end_function
function StringIsInteger global string lsString returns integer
  integer liPos liLen
  move (trim(lsString)) to lsString
  if (left(lsString,1)="-") move (replace("-",lsString,"")) to lsString
  move (length(lsString)) to liLen
  for liPos from 1 to liLen
    ifnot (pos(mid(lsString,1,liPos),"0123456789")) function_return DFFALSE
  loop
  function_return DFTRUE
end_function

function StringFieldType global integer liType returns string
  if liType eq DF_ASCII   function_return "ASCII"
  if liType eq DF_BCD     function_return "Number"
  if liType eq DF_DATE    function_return "Date"
  if liType eq DF_OVERLAP function_return "Overlap"
  if liType eq DF_TEXT    function_return "Text"
  if liType eq DF_BINARY  function_return "Binary"
  function_return "Un-defined"
end_function

function StringFieldLenText global integer liType integer liLen integer liDec returns string
  if liType eq DF_BCD function_return (NumToStr(liLen+(liDec/10.0),1))
  else function_return (string(liLen))
end_function
function StringFieldText global integer liType integer liLen integer liDec returns string
  string lsRval
  move "# (#)" to lsRval
  replace "#" in lsRval with (StringFieldType(liType))
  replace "#" in lsRval with (StringFieldLenText(liType,liLen,liDec))
  function_return lsRval
end_function


function StringConsistsOf global string src# string tpl# returns integer
  integer count# len#
  trim src# to src#
  move (length(src#)) to len#
  for count# from 1 to len#
    ifnot (mid(src#,1,count#)) in tpl# function_return 0
  loop
  function_return 1
end_function

function StringBeginsWith global string lsHostString string lsLeadInCharacters returns integer
  function_return (left(lsHostString,length(lsLeadInCharacters))=lsLeadInCharacters)
end_function

function StringEndsWith global string lsHostString string lsTrailingCharacters returns integer
  function_return (right(lsHostString,length(lsTrailingCharacters))=lsTrailingCharacters)
end_function

function StringReverse global string lsValue returns string
  integer liLen liPos
  string lsRval lsChar
  move "" to lsRval
  move (length(lsValue)) to liLen
  for_ex liPos from liLen down_to 1
    move (lsRval+mid(lsValue,1,liPos)) to lsRval
  loop
  function_return lsRval
end_function

function StringHead global string lsValue string lsDlm returns string
  integer liLen liPos
  move (length(lsValue)) to liLen
  for liPos from 1 to liLen
    if (lsDlm contains mid(lsValue,1,liPos)) function_return (left(lsValue,liPos-1))
  loop
  function_return lsValue
end_function

function StringTail global string lsValue string lsDlm returns string
  integer liLen liPos
  move (length(lsValue)) to liLen
  for liPos from 1 to liLen
    if (lsDlm contains mid(lsValue,1,liPos)) function_return (right(lsValue,liLen-liPos))
  loop
  function_return ""
end_function

// If function ConvertChar is not already defined we define it here:
#IFDEF get_ConvertChar
#ELSE
 use WinBase
 Function ConvertChar Global integer bToAnsi String sString Returns String
   pointer psString
   integer iVoid bIsCString
   Move (ascii(Right(sString,1))=0) to bIsCString
   If Not bISCString Append sString (character(0))
   GetAddress Of sString To psString
   if bToAnsi Move (OEMToANSI(psString,psString)) To iVoid
   else       Move (ANSItoOEM(psString,psString)) To iVoid
   Function_Return (if(bIsCString, sString, cstring(sString)))
 End_Function
#ENDIF

function StringAnsiToOem global string str# returns string
   function_return (ConvertChar(0,str#))
end_function

function StringOemToAnsi global string str# returns string
   function_return (ConvertChar(1,str#))
end_function

function RemoveDblBlanks global string lsValue returns string
  integer fin#
  move 0 to fin#
  repeat
    move (replaces("  ",lsValue," ")) to lsValue
    ifnot "  " in lsValue move 1 to fin#
  until fin#
  function_return lsValue
end_function

function vdfq_ByteToHex global integer byte# returns string
  function_return (mid("0123456789ABCDEF",1,byte#/16+1)+mid("0123456789ABCDEF",1,(byte# iand 15)+1))
end_function

function vdfq_HexToByte global string lsHex returns integer
  function_return (pos(left(lsHex,1),"0123456789ABCDEF")-1*16+pos(right(lsHex,1),"0123456789ABCDEF")-1)
end_function

function vdfq_StringToHex global string lsValue returns string
  integer liLen liPos
  string lsRval
  move (length(lsValue)) to liLen
  move "" to lsRval
  for liPos from 1 to liLen
    move (string(lsRval)+string(vdfq_ByteToHex(ascii(mid(lsValue,1,liPos))))) to lsRval
  loop
  function_return lsRval
end_function

function vdfq_HexToString global string lsValue returns string
  integer liLen liPos
  string lsRval
  move (length(lsValue)/2) to liLen
  move "" to lsRval
  for liPos from 1 to liLen
    move (string(lsRval)+string(vdfq_HexToByte(ascii(mid(lsValue,2,liPos*2-1))))) to lsRval
  loop
  function_return lsRval
end_function

function Text_RemoveTrailingCr global string lsValue returns string
  integer fin#
  string char# char10# char255# char13#
  move 0 to fin#
  move (character(10)) to char10#
  move (character(13)) to char13#
  move (character(255)) to char255#
  repeat
    ifnot (length(lsValue)) function_return ""
    move (right(lsValue,1)) to char#
    if (char#=char10# or char#=" " or char#=char13# or char#=char255#) move (left(lsValue,(length(lsValue)-1))) to lsValue
    else move 1 to fin#
  until fin#
  function_return lsValue
end_function

function Text_RTrim global string lsValue returns string
  move (rtrim(replaces(character(255),lsValue," "))) to lsValue
  function_return (Text_RemoveTrailingCr(lsValue))
end_function

function Text_Trim global string lsValue returns string
  move (trim(replaces(character(255),lsValue," "))) to lsValue
  function_return (Text_RemoveTrailingCr(lsValue))
end_function

function Text_Compress global string lsValue returns string
  move (replaces(character(10),lsValue," ")) to lsValue
  trim lsValue to lsValue
  move (RemoveDblBlanks(lsValue)) to lsValue
  function_return lsValue
end_function

function Text_CompressSubstCr global string lsValue string new_line# returns string
  move (replaces(character(13),lsValue,"")) to lsValue
  function_return (RemoveDblBlanks(trim(replaces(character(10),Text_RemoveTrailingCr(lsValue),new_line#))))
end_function

class cText_Formatter is an array
  procedure construct_object integer img#
    forward send construct_object img#
    property integer pRmargin        public 40
    property integer pCompress_state public 0
    property integer pTrim_state     public 1 // 0=no trim, 1=trim, 2=rtrim
    property integer pSubst_below_32_state public 0
  end_procedure

  procedure add_item.s string lsValue
    integer char#
    if (pSubst_below_32_state(self)) begin
      for char# from 0 to 31
        move (replaces(character(char#),lsValue," ")) to lsValue
      loop
    end
    set array_value item (item_count(self)) to lsValue
  end_procedure

  function split_word string lsValue integer len# returns string
    integer pos#
    string rval#
    move (pos("-",lsValue)) to pos#
    if (pos# and pos#<=len#) move (replace("-",lsValue," ")) to rval#
    else begin
      move (left(lsValue,len#)) to rval#
      move (rval#+" "+replace(rval#,lsValue,"")) to rval#
    end
    function_return rval# // The space in the return value indicates
  end_function            // where to split the word

  procedure format.s string lsValue
    integer Trim_state# done# pRmargin# word_done# pos# max# len#
    string word# line# lf# left# char#

    //pre-format:
    get pTrim_state to Trim_state#
    if Trim_state# eq 1 move (Text_Trim(lsValue)) to lsValue
    else if Trim_state# eq 2 move (Text_RTrim(lsValue)) to lsValue
    if (pCompress_state(self)) move (Text_Compress(lsValue)) to lsValue

    move (character(10)) to lf#
    get pRmargin to pRmargin#
    if pRmargin# gt 1 begin // Otherwise nothing makes sense!
      move 0 to done#
      move "" to line#
      move 1 to pos#
      move (length(lsValue)) to max#
      repeat

        move "" to word#
        move 0 to word_done#
        repeat
          if pos# gt max# move 1 to word_done#
          else begin
            mid lsValue to char# 1 pos#
            if char# eq lf# begin // Line feed
              if word# eq "" begin
                move lf# to word#
                increment pos#
              end
              move 1 to word_done#
            end
            else begin
              if char# eq "" begin
                if word# eq "" increment pos#
                else move 1 to word_done#
              end
              else begin
                move (word#+char#) to word#
                increment pos#
              end
            end
          end
        until word_done#

        if word# eq "" move 1 to done# // We're done!
        else begin
          if word# eq lf# begin // If hard return:
            send add_item.s line#
            move "" to line#
          end
          else begin //
            if (length(line#)+length(word#)+1) gt pRmargin# begin // Soft new line
              if line# ne "" begin
                send add_item.s line# // Could be that word is longer that pRmargin
                move "" to line#
              end
              if (length(word#)) gt pRmargin# begin // Word IS longer that line!
                repeat
                  if line# eq "" move (pRmargin#-1) to len#
                  else move (pRmargin#-length(line#)-2) to len#
                  move (split_word(self,word#,len#)) to word#
                  move (ExtractItem(word#," ",1)) to left#
                  move (ExtractItem(word#," ",2)) to word#
                  if word# eq "" move left# to line#
                  else send add_item.s (left#+"-")
                until word# eq ""
              end
              else move word# to line#
            end
            else begin
              if line# ne "" move (line#+" "+word#) to line# // add word to line
              else move word# to line#
            end
          end
        end
      until done#
      if line# ne "" send add_item.s line#
    end
  end_procedure
end_class // cText_Formatter

desktop_section
  object oText_Formatter is a cText_Formatter no_image
    set pSubst_below_32_state to DFTRUE
  end_object
end_desktop_section

procedure Text_Format_Reset global
  send delete_data to (oText_Formatter(self))
end_procedure

function Text_Format_LineCount global returns integer
  function_return (item_count(oText_Formatter(self)))
end_function

function Text_Format.sii global string lsValue integer liWidth integer lbReset returns integer
  integer lhObj
  if lbReset send Text_Format_Reset
  move (oText_Formatter(self)) to lhObj
  set pRmargin of lhObj to liWidth
  send format.s to lhObj lsValue
  function_return (item_count(lhObj))
end_function

function Text_FormattedLine.i global integer liLine returns string
  function_return (string_value(oText_Formatter(self),liLine))
end_function

function Text_FormattedText global returns string
  integer liItem liMax liObj
  string lsRval
  move "" to lsRval
  move (oText_Formatter(self)) to liObj
  get item_count of liObj to liMax
  get Text_Format_LineCount to liMax
  decrement liMax
  for liItem from 0 to liMax
    move (lsRval+value(liObj,liItem)) to lsRval
    if liItem ne liMax move (lsRval+character(10)) to lsRval
  loop
  function_return lsRval
end_function

string gs$CollateString 255 // Here's the string

object oCollateStringBuilder is an Array
  procedure MakeCollateString
    integer liCharacter liMax liItem
    string lsRval
    for liCharacter from 32 to 255
      set value item (liCharacter-32) to (character(liCharacter))
    loop
    send sort_items DESCENDING // We need them backwards
    get item_count to liMax
    decrement liMax
    move "" to lsRval
    for liItem from 0 to liMax
      move (lsRval+value(self,liItem)) to lsRval
    loop
    move (repeat(" ",31)+lsRval) to gs$CollateString
    send delete_data
  end_procedure
  send MakeCollateString
end_object

function String_NegateSortOrder global string lsValue returns string
  integer liPos liLen
  string lsRval lsChar
  move (length(lsValue)) to liLen
  move "" to lsRval
  for liPos from 1 to liLen
    move (mid(lsValue,1,liPos)) to lsChar
    move (lsRval+mid(gs$CollateString,1,ascii(lsChar))) to lsRval
  loop
  function_return lsRval
end_function

// The same function (StringEncrypt) is used to encrypt and decrypt a string:
//
//   ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿
//   ³                                                        ³
//   ³       StringEncrypt(string,code)                       ³
//   ³               ³  stringEncrypt(encrypted_string,code)  ³
//   ³               ³                      ³                 ³
//   ³                                                      ³
//   ³     <string> -- <encrypted_string> -- <string>       ³
//   ³                                                        ³
//   ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ
//
// The code used to encrypt a string may be any integer value and must
// be the same when decrypting
//

         function iEncryptXor.iii global integer liX integer liY integer liBitCount returns integer
           integer liRval liBit liXbit liYbit liBitExp
           move 0 to liRval
           for liBit from 0 to (liBitCount-1)
             move (2^liBit) to liBitExp
             move ((liX/liBitExp)-(((liX/liBitExp)/2)*2)) to liXbit
             move ((liY/liBitExp)-(((liY/liBitExp)/2)*2)) to liYbit
             if liXbit ne liYbit move (liRval+liBitExp) to liRval
           loop
           function_return liRval
         end_function

function StringEncrypt global string lsInput integer liCode integer liLen returns string
  integer liPos
  string lsRval
  move "" to lsRval
  for liPos from 1 to liLen
    move (lsRval+character(iEncryptXor.iii(ascii(mid(pad(lsInput,liLen),1,liPos)),((liCode+(liPos*7)) iand 31),8))) to lsRval
  loop
  function_return lsRval
end_function

// The function returns the number of items that the value was split into. Negative if parsing error
//
// lsValue is the string to split
// lsSeparatorChar is the separating character
// lbDiscardDblSeps determines whether succeeding separating characters are to be considered as one
// lbProtectQuotes determines if items in quotes should be
function StringSplitToArrayObj global string lsValue string lsSeparatorChar integer lbDiscardDblSeps integer lbProtectQuotes integer lhTargetArray returns integer
  integer liLen      // Length of the string we are parsing
  integer liItem     // Pointer to the next available index in the target array (lhTargetArray)
  integer liStartItem // Number of items originally in the target array
  integer liPos      // The current position in the string (lsValue) we are parsing

  string  lsChar      // The character currently being examined by the loop
  string  lsItem      // The value of the next item as it is being built
  string  lsQuoteChar // If " or ', we are currently in a quoted section of the string
  string  lsQuotes    // Quotation characters: "'

  move "" to lsQuoteChar
  get item_count of lhTargetArray to liStartItem // If the array is not empty, we just add to its current content.
  move liStartItem to liItem
  move (length(lsValue)) to liLen
  move "" to lsItem
  move ("'"+'"') to lsQuotes

  move 1 to liPos
  while (liPos<=liLen)
    move (mid(lsValue,1,liPos)) to lsChar
    increment liPos

    if (lsQuoteChar<>"") begin
      if (lsChar=lsQuoteChar) begin
        move "" to lsQuoteChar
        if (liPos<=liLen) begin // Next item MUST be a separating character or end of string
          move (mid(lsValue,1,liPos)) to lsChar
          if (lsChar<>lsSeparatorChar) function_return (0-liPos) // Error: Illegal character after quoted string
        end
     // else it's the end of the string and we're therefore OK
      end
      else begin
        move (lsItem+lsChar) to lsItem
      end
    end
    else begin // We're not in a quote
      if (lsChar=lsSeparatorChar) begin
        set value of lhTargetArray item liItem to lsItem
        increment liItem
        move "" to lsItem

        if lbDiscardDblSeps begin // succeeding separating characters are to be considered as one, we advance the position accordingly
          while (liPos<liLen and mid(lsValue,1,liPos)=lsSeparatorChar)
            increment liPos
          end
        end
      end
      else if (lbProtectQuotes<>0 and lsQuotes contains lsChar) begin
        if (lsItem="") begin
          move lsChar to lsQuoteChar
        end
        else function_return (0-liPos+1)  // Error: Illegal position of quotation character
      end
      else move (lsItem+lsChar) to lsItem
    end
  end

  if (lsItem<>"") begin
    set value of lhTargetArray item liItem to lsItem
    increment liItem
  end

  if (lsQuoteChar<>"") function_return (0-liPos) // Error: Quoted string not terminated
  function_return (liItem-liStartItem) // Return number of items added to the target array
end_function // StringSplitToArrayObj