Gestion de chaine

' *************************************************************************************************************************
'                FONCTIONS/PROCEDURES CHAINE DE CARACTERES
' LIBRAIRIE: LibStr.bas
' AUTEUR  : Nardo26  18/09/12
' Modif    : 20/11/12 Syntaxe de StrObjectId()
' Modif    : 25/09/12 Maj syntaxe
' Modif    : 16/10/12 Syntaxe de EXPLODE revue pour être en accord avec la syntaxe de INSTR
'
' REFS : Divers PHP,PERL,C,etc...
'
' LISTE DES FONCTIONS/PROCEDURES:
'
'  EXPLODE(S1,S2,liste)      Retourne une liste de chaînes, chacune d'elle étant une sous-chaîne du paramètre S1 extraite en utilisant le séparateur S2
'  RInstr%(S1$, S2$)          Renvoie la position du 1er caractère de S2 dans S1 en partant de la droite
'  StrPad$(S1$,L%, S2$, F%)  Complète la chaîne S1 avec les caractères prédéfinis dans S2 pour une longueur totale L%
'  StrReplace$(S1$, S2$, S3$) Remplace la chaine S2 dans S1 par la chaine S3
'  StrSplit$(S1$, S2$)        Découpe en 2 partie la chaine S1 à partir du séparateur S2$
'  StrCount%(S1$, S2$)        Comptage de l'occurrence du texte S2 dans la chaine S1
'  StrCmp%(S1$, S2$, case%)  Comparaison de 2 chaines de caractères
'  StripAccent$(S1$)          Enlève les accents de la chaine de caractères S1
'  UCFirst$(S1$)              Met la 1ere lettre de S1 en MAJUSCULE, le reste en minuscules.
'  UCWord$(S1$)              Met la 1ere lettre de chaque mot de S1 en MAJUSCULE le reste en minuscule
' *************************************************************************************************************************
DIM strLib_version : strLib_version = 102
LABEL StrEndLib : GOTO StrEndLib

' ------------------------------------------------------------------------------
' EXPLODE(S1,S2,liste)
' @info Retourne une liste de chaînes, chacune d'elle étant une sous-chaîne du paramètre S1 extraite en utilisant le séparateur S2
' @param S1 Chaine de caractères
' @param S2 séparateur
' @param Liste N° de la (d)liste de retour
' @@@@
' ------------------------------------------------------------------------------
SUB EXPLODE(chaine$,delimiter$,liste%)
  CLEAR liste%
  WHILE INSTR(chaine$,delimiter$)<>0
    ITEM_ADD liste%,LEFT$(chaine$,INSTR(chaine$,delimiter$)-1)
    chaine$=RIGHT$(chaine$,LEN(chaine$)-INSTR(chaine$,delimiter$))
  END_WHILE
  ITEM_ADD liste%,chaine$
END_SUB

' ------------------------------------------------------------------------------
' StrCmp%(S1,S2,I)
' @info Comparaison de 2 chaines de caractères
' @param S1 Chaine de caractères
' @param S2 Chaine de caractères
' @param I  1:Ignore majuscule/minuscule
' @return StrCmp_return%  -1:inf, 0:egal, 1:sup
' @@@@
' ------------------------------------------------------------------------------
SUB StrCmp%(S1$,S2$,I%)
DIM_LOCAL tmpLst%
  IF VARIABLE("StrCmp_return%")=0 THEN DIM StrCmp_return%
  IF I% = 1 THEN S1$ = UPPER$(S1$) : S2$ = UPPER$(S2$)
  IF S1$ = S2$
    StrCmp_return%=0
  ELSE
    StrObjectId%(ADR(tmpLst%)): DLIST tmpLst%
    ITEM_ADD StrObjectId_return%, S1$
    ITEM_ADD StrObjectId_return%, S2$
    SORT_ON StrObjectId_return%
    IF (S1$ = ITEM_READ$(StrObjectId_return%,1)) : StrCmp_return% = -1:ELSE: StrCmp_return% = 1:END_IF
    CLEAR tmpLst%:DELETE tmpLst%
  END_IF
END_SUB
' ------------------------------------------------------------------------------
' StrCount%(S1,S2)
' @info Comptage du nb de fois qu'il y a S2 dans S1
' @param S1 Chaine de caractères
' @param S2 Chaine de caractères
' @return StrCount_return%
' @exemple
' StrCount%("abcABCaBCabc", "abc"):PRINT StrCount_return%: ' affiche 2
' StrCount(LOWER$("abcABCaBCabc"), "abc"):PRINT StrCount_return%: ' affiche 4
' @@@@
' ------------------------------------------------------------------------------
SUB StrCount%(S1$,S2$)
  IF VARIABLE("StrCount_return%")=0 THEN DIM StrCount_return%
  DIM_LOCAL i%:i%=0
  WHILE INSTR(S1$,S2$)<>0
    S1$ = MID$(S1$,INSTR(S1$,S2$)+LEN(S2$),200)
    i% = i% + 1
  END_WHILE
  StrCount_return% = i%
END_SUB

' ------------------------------------------------------------------------------
' StrReplace$(S1,S2,S3)
' @info Remplace une chaine par une autre
' @param S1 chaine à modifier
' @param S2 chaine à remplacer
' @param S3 chaine de remplacement
' @return StrReplace_return$
' @@@@
' ------------------------------------------------------------------------------
SUB StrReplace$(S1$,S2$,S3$)
  IF VARIABLE("StrReplace_return$")=0 THEN DIM StrReplace_return$
  WHILE INSTR(S1$,S2$) <> 0
    StrSplit$(S1$,S2$)
    S1$ = StrSplit_return$(0) + S3$ + StrSplit_return$(1)
  END_WHILE
  StrReplace_return$ = S1$
END_SUB

' ------------------------------------------------------------------------------
' Rinstr%(S1, S2)
' @info Renvoie la position de S2 dans la chaine de caractere S1 en partant de la droite
' @param S1$ Chaine de caractères
' @param S2$ Chaine de caractères
' @return Rinstr_return%
'
' @exemple
' DIM EMail$ : EMail$ = "nardo.26@truc.fr";
' PRINT INSTR(EMail$ , ".") :' affiche 6
' RINSTR(EMail$ , ".") : PRINT Rinstr_return% : ' affiche  14
' @@@@
' ------------------------------------------------------------------------------
SUB RINSTR%(S1$,S2$)
  IF VARIABLE("Rinstr_return%")=0 THEN DIM Rinstr_return%
  DIM_LOCAL i%:i%=0
  IF INSTR(S1$,S2$)<>0
    FOR i%=LEN(S1$) TO 1 STEP -1
      IF INSTR(RIGHT$(S1$,LEN(S1$)-i%+1),S2$)<> 0 THEN EXIT_FOR
    NEXT i%
  END_IF
  Rinstr_return% = i%
END_SUB

' ------------------------------------------------------------------------------
' StrPad$(S1,L,S2,F)
' @info Complète la chaîne de caractères S1 avec un ou plusieurs caractères prédéfinis dans S2
' @param S1 La chaine de caractères à compléter
' @param L  Longueur de la chaine finale
' @param S2 Chaine ou caractère de remplissage
' @param F  0:remplissage à gauche, 1:remplissage à droite
' @return StrPad_return$
' @exemple
' REM                                            11111111112
' REM                                    12345678901234567890
' REM                                    --------------------
' StrPad$("Nardo26", 20, "-._", 0) :'    -._-._-._-._-Nardo26
' strPad$("Nardo26", 20, "-._", 1) :'    Nardo26-._-._-._-._-
' @@@@
' ------------------------------------------------------------------------------
SUB StrPad$(S1$,L%,S2$,F%)
  IF VARIABLE("StrPad_return$")=0 THEN DIM StrPad_return$
  DIM_LOCAL S3$ : S3$ = ""
  WHILE LEN(S3$) < L% : S3$ = S3$ + S2$ : END_WHILE
  IF F%=0
    S3$ = LEFT$(S3$, L% - LEN(S1$)) + S1$
  ELSE
    S3$ = S1$ + LEFT$(S3$, L% - LEN(S1$))
  END_IF
  StrPad_return$ = S3$
END_SUB


' ------------------------------------------------------------------------------
' StrSplit$(S1,S2)
' @info Décompose en 2 la chaine de caractères S1 à partir du caractère S2
' @param S1 Chaine de caractères à découper
' @param S2 Caractère ou chaine de séparation
' @return StrPlit_return$(2) (tableau de 2 éléments)
' @@@@
' ------------------------------------------------------------------------------
SUB StrSplit$(S1$,S2$)
  IF VARIABLE("StrSplit_return$")=0 THEN DIM StrSplit_return$(2)
  IF INSTR(S1$,S2$)<>0
    StrSplit_return$(0) = LEFT$(S1$,INSTR(S1$,S2$)-1)
    StrSplit_return$(1) = RIGHT$(S1$,LEN(S1$)-LEN(StrSplit_return$(0))-LEN(S2$))
  END_IF
END_SUB

' ------------------------------------------------------------------------------
' UCFirst$(S1)
' @info Met la 1ère lettre de la chaîne S1 en Majuscule, le reste en minuscule.
' @param S1 Chaine de caractères
' @return UCFirst_return$
' @exemple
' UCFirst$("salut tout le monde. ca va ?")
' PRINT UCFirst_return$ : REM affiche "Salut tout le monde. ca va ?"
' @@@@
' ------------------------------------------------------------------------------
SUB UCFirst$(S1$)
  IF VARIABLE("UCFirst_return$")=0 THEN DIM UCFirst_return$
  UCFirst_return$ = UPPER$(LEFT$(S1$,1)) + LOWER$(RIGHT$(S1$,LEN(S1$)-1))
END_SUB

' ------------------------------------------------------------------------------
' UCWord$(S1)
' @info Met la première lettre de chaque mot d'une chaîne en Majuscule.
' @param S1 Chaine de caractères
' @return UCWord_return$
' @exemple
' UCWord$("salut tout le monde")
' PRINT UCWord_return$ :  REM Résultat : "Salut Tout Le Monde"
' @@@@
' ------------------------------------------------------------------------------
SUB UCWord$(S1$)
  IF VARIABLE("UCWord_return$")=0 THEN DIM UCWord_return$
  DIM_LOCAL S2$: S2$=""
  UCFirst$(S1$) : S1$ = UCFirst_return$
  WHILE INSTR(S1$," ")<>0
    StrSplit$(S1$," "): UCFirst$(StrSplit_return$(0))
    S2$ = S2$ + UCFirst_return$ + " "
    UCFirst$(StrSplit_return$(1)) : S1$ = UCFirst_return$
  END_WHILE
  S2$ = S2$ + S1$
  UCWord_return$ = S2$
END_SUB

' ------------------------------------------------------------------------------
' StripAccent$(S1)
' @info Supprime les accents dans une chaine de caractères
' @param S1 Chaine de caractères
' @return StripAccent_return$
' @exemple : "chaîne de caractères" -> "chaine de caracteres"
' @@@@
' ------------------------------------------------------------------------------
SUB StripAccent$(S1$)
  IF Variable("StripAccent_return$")=0 THEN DIM StripAccent_return$
  DIM_LOCAL i%,j%
  DIM strAccent$(2):strAccent$(0)="àèéêëîôù":strAccent$(1)="aeeeeiou"
  StripAccent_return$=""
  FOR i%=1 TO LEN(S1$)
    j% = INSTR(strAccent$(0),MID$(S1$,i%,1))
    IF j%=0
      StripAccent_return$ = StripAccent_return$+MID$(S1$,i%,1)
    ELSE
      StripAccent_return$ = StripAccent_return$+MID$(strAccent$(1),j%,1)
    END_IF
  NEXT i%
  FREE strAccent$
END_SUB


' ------------------------------------------------------------------------------
' Procédure interne pour fonctionnement de la librairie
' Renvoie un numéro d'objet libre
' ------------------------------------------------------------------------------
SUB StrObjectId%(p_r%)
  DIM_LOCAL i%:i%=1
  i% = 1
  WHILE OBJECT_EXISTS(i%) = 1 : i% = i% + 1 : END_WHILE
  POKE p_r%,i%
END_SUB
StrEndLib:

' ******************************************************************************
'                    FONCTIONS/PROCEDURES BINAIRES
'
' LIBRAIRIE: LibBin.bas
'
' AUTEUR  : Nardo26
' Création : 1.0.0  18/09/12  Création de StrToCCITT, StrToCRC16,
' Modif    : 1.1.0  25/09/12  Ajout StrToCrcModbus
' Modif    : 1.2.0  16/10/12  Ajout FlipBits,Bcd2Bin,LPEEK,DUMP,VarExists,GetName
'
'
' LISTE DES FONCTIONS/PROCEDURES:
'  StrToCCITT(t$)        renvoie le CRC_CCITT d'une chaine de caractères
'  StrToCRC16(t$)        calcule le CRC16 d'une chaine de caractères
'  StrToCrcModbus(t$)    calcule le CRC d'une trame modbus
'  FlipBits(adresse_int%) inverse les poids forts/poids faibles sur un entier (32 bits)
'  Bcd2Bin(t$)            convertion d'une chaine codée HEXA en BINAIRE naturel
'  LPEEK(ad%)            renvoie la valeur de l'entier (32 bits) situé à l'adresse ad%
'  DUMP(ad%)              affiche le dump des 16 octets qui se trouvent à l'adresse ad%
'  VarExists(t$)          permet de tester l'existence d'une variable par son nom
'
' ******************************************************************************
DIM binLib_version : binLib_version = 120
LABEL binLib_End : GOTO binLib_End

' ------------------------------------------------------------------------------
' StrToCCITT(t$) renvoie le CRC (norme CCITT) d'une chaine de caractères
' ------------------------------------------------------------------------------
SUB StrToCCITT%(t$)
  DIM_LOCAL i%
  IF VARIABLE("StrToCCITT_return%")=0 THEN DIM StrToCCITT_return%
  StrToCCITT_return% = HEX("FFFF00")
  FOR i%=1 TO LEN(t$): OneByteCrc16(ASC(MID$(t$,i%,1))) : NEXT i%
  OneByteCrc16(0)
  OneByteCrc16(0)
  StrToCCITT_return% = BIN_AND(StrToCCITT_return%,HEX("FFFF00"))
  StrToCCITT_return% = INT(StrToCCITT_return% / 256)
END_SUB

' Necessaire pour StrToCCITT()
SUB OneByteCrc16(Byte)
 DIM_LOCAL i:i=8
  StrToCCITT_return% = BIN_AND(StrToCCITT_return%,HEX("FFFFFF00"))+Byte
  REPEAT
    StrToCCITT_return% = BIN_AND(StrToCCITT_return%*2,HEX("FFFFFFFF"))
    IF BIN_AND(StrToCCITT_return%,HEX("1000000"))<>0
      StrToCCITT_return% = BIN_XOR(StrToCCITT_return%,HEX("102100"))
    END_IF
    i=i-1
  UNTIL i=0
END_SUB

' ------------------------------------------------------------------------------
' StrToCRC16(t$) calcule le CRC16 d'une chaine de caractères
' ------------------------------------------------------------------------------
SUB StrToCrc16(t$)
  DIM_LOCAL i,j,mask
  IF VARIABLE("StrToCrc16_return")=0 THEN DIM StrToCrc16_return
  StrToCrc16_return=0
  FOR i=1 TO LEN(t$)
  j=ASC(MID$(t$,i,1))
  StrToCrc16_return = BIN_XOR(StrToCrc16_return,j)
  FOR j=1 TO 8
    mask=0
    IF MOD(StrToCrc16_return,2)=1 THEN mask=HEX("A001")
    StrToCrc16_return=BIN_AND(INT(StrToCrc16_return/2),HEX("7FFF"))
    StrToCrc16_return = BIN_XOR(StrToCrc16_return,mask)
  NEXT j
  NEXT i
END_SUB

' ------------------------------------------------------------------------------
' Calcul du Crc (protocole modbus) d'une chaine de caractères
' ------------------------------------------------------------------------------
SUB StrToCrcModbus(t$)
  IF VARIABLE("StrToCrcModbus_return%")=0 THEN DIM StrToCrcModbus_return%
  DIM_LOCAL i%,j%,ct%,ch%
  StrToCrcModbus_return% = HEX("FFFF")
  FOR i%=1 TO LEN(t$)
  StrToCrcModbus_return% = BIN_XOR(StrToCrcModbus_return%,ASC(MID$(t$,i%,1)))
  FOR j%=1 TO 8
    ct% = BIN_AND(StrToCrcModbus_return%,1) : ch%=0
    IF BIN_AND(StrToCrcModbus_return%,HEX("7FFF"))<>StrToCrcModbus_return%
      StrToCrcModbus_return% = BIN_AND(StrToCrcModbus_return%,hex("7FFF")) : ch%=1
    END_IF
    ' bien que StrToCrcModbus_return% soit un entier, il faut OBLIGATOIREMENT
    ' faire un INT() car une expression "entier/n" renverra un reel
    StrToCrcModbus_return% = INT(StrToCrcModbus_return% / 2)
    if ch%=1 THEN StrToCrcModbus_return% = BIN_OR(StrToCrcModbus_return%,hex("4000"))
    if ct%=1 THEN StrToCrcModbus_return% = BIN_XOR(StrToCrcModbus_return%,HEX("A001"))
  NEXT j%
  NEXT i%
END_SUB

' ------------------------------------------------------------------------------
' Inverse les poids forts avec les poids faibles sur un entier (32 bits)
' paramètre: ad% Adresse de la variable entière à inverser
' ------------------------------------------------------------------------------
SUB FlipBits(ad%)
  DIM_LOCAL i%,j%
  FOR i%=0 TO 3 step 2
    j% = PEEK(ad%+i%)
    POKE ad%+i%,PEEK(ad%+i%+1)
    POKE ad%+i%+1,j%
  NEXT i%
END_SUB


' ------------------------------------------------------------------------------
' Convertion d'une chaine codée HEXA en BINAIRE naturel
' Exemple :
' la chaine "32030000000A" de 12 caractères sera codée en une chaine de 6 octets contenants : 32 03 00 00 00 0A
' ------------------------------------------------------------------------------
SUB Bcd2Bin(t$)
  DIM_LOCAL i%,oct%
  IF VARIABLE("Bcd2Bin_return$")=0 THEN DIM Bcd2Bin_return$
  oct%=0 :Bcd2Bin_return$=""
  FOR i%=1 TO LEN(t$)
    oct%=oct%+(HEX(MID$(t$,i%,1))*((ODD(i%)*15)+1))
    IF EVEN(i%)=1
      Bcd2Bin_return$ = Bcd2Bin_return$+chr$(oct%)
      oct%=0
    END_IF
  NEXT i%
END_SUB

' ------------------------------------------------------------------------------
' Renvoie la valeur de l'entier (32 bits) situé à l'adresse ad%
' ------------------------------------------------------------------------------
SUB LPEEK(ad%)
  IF VARIABLE("LPEEK_return%")=0 THEN DIM LPEEK_return%
  DIM_LOCAL Value%,i%,Value$,c%
  Value% = 0
  FOR i%=0 TO 3
    c%=PEEK(ad%+i%)
    IF c%<16 : Value$="0"+HEX$(c%)+Value$
    ELSE:Value$=HEX$(c%)+Value$:END_IF
  NEXT i%
  LPEEK_return% = HEX(Value$)
END_SUB

' -----------------------------------------------------------------
' Permet de tester l'existence d'une variable par son nom
' retour: adresse de la structure de définition sinon renvoie 0
' -----------------------------------------------------------------
SUB VarExists(t$)
  IF VARIABLE("VarExists_return%")=0 THEN DIM VarExists_return%
  VarExists_return%=ADR(NUMBER_3D_OBJECTS)-24
  t$=UPPER$(t$)
  REPEAT
    VarExists_return%=VarExists_return%+80
    GetName(VarExists_return%)
  UNTIL GetName_return$=t$ OR GetName_return$=""
  IF GetName_return$="" THEN VarExists_return%=0:EXIT_SUB
END_SUB
' ------------------------------------------------------------------------------
' Affiche le dump des 16 octets qui se trouvent à l'adresse ad%
' ------------------------------------------------------------------------------
SUB DUMP(Ad%)
  DIM_LOCAL i%,v%,a$,b$
  a$="":b$=""
  FOR i%=0 TO 15
    v%=PEEK(Ad%+i%)
    IF v%<16 : a$=a$+"0"+HEX$(v%)+" "
    ELSE:a$=a$+HEX$(v%)+" ":END_IF
    if MOD(i%+1,4)=0 THEN a$=a$+" "
    if v%>31:b$=b$+chr$(v%)
    ELSE:b$=b$+".":END_IF
  NEXT i%
  PRINT HEX$(Ad%)+" :"+a$+"  "+b$
END_SUB
' -----------------------------------------------------------------
' Récupère le contenu d'une chaine Delphi
' -----------------------------------------------------------------
SUB GetName(Ad%)
  DIM_LOCAL pStart%,pName%,lStr%
  DIM_LOCAL ch$,i%
  IF VARIABLE("GetName_return$")=0 THEN DIM GetName_return$
  GetName_return$=""
  LPEEK(Ad%):pName%=LPEEK_return%
  IF pName%<>0
    LPEEK(pName%-4):lStr%=LPEEK_return%
    FOR i%=0 TO lStr%-1
      GetName_return$=GetName_return$+CHR$(PEEK(pName%+i%))
    NEXT i%
  END_IF
END_SUB
binLib_End: