DEFINT A-Z
' --- INPUT MODULES---
DECLARE FUNCTION druke(a$, b$, c$)      'inputroutine één karakter, met prompt (a$), default (c$) en test, roept inx$ aan
                                        'resultaat zit in b$, druke is true indien * gedrukt of timeout
DECLARE FUNCTION inpx$(a$, b$, l%)      'line input routine, a$=prompt, b$=default, l%=maxlength, roept inx$ aan
                                        'aanvaard volgende editeertoetsen <esc> <ins> <del> <home> <end> <csr left> <csr right> <tab> <backsp> <*>
                                        'en <csr up> <csr down> indien upos true is
DECLARE SUB ppp(a$, j%, i%)             'a$=te printen tekst, i%=attributen, j%=CR+LF
DECLARE FUNCTION scanline$(a$)          'Zoekst naar < en > voor schermobbouw en controle geldige tekens
DECLARE FUNCTION inx$()                 'inputroutine één karakter
                                        'gebruikt ty als timeout-waarde

' --- INI FILE HANDLING ---
DECLARE FUNCTION getini$(a$, b$)        'a$=initfile, b$=te zoeken parameter
DECLARE SUB setini(a$, b$, c$)          'a$=initfile,b$=te zoeken parameter, c$=nieuwe waarde
DECLARE FUNCTION getval$(a$, b$)        'a$=initfile, b$=te zoeken waarde (rechts) [geeft parameter]

' --- RANDOM LENGTH FILE HANDLING ---
DECLARE FUNCTION setline(file$, text$) AS DWORD
                                        'voegt één record toe aan file$, resultaat = startpositie
DECLARE FUNCTION getline$(file$, position AS DWORD)
                                        'leest één record van de file$, vanaf positie position
DECLARE SUB killline(file$, position AS DWORD)
                                        'wist één record uit het bestand

     ' %bold = 1: %blink = 2: %rev = 4
     %ins = 82: %home = 71: %pup = 73: %del = 83: %end = 79:  %pdown = 81
     %back = 75: %forw = 77
      %upn = 72: %downn = 80
      %up = 88: %down = 87
     %backsp = 308: %enter = 313: %y = 325: %esc = 327: %tab = 309

     GLOBAL note AS INTEGER             ' is het een notebook ?
     GLOBAL insr AS INTEGER             ' thread terminated ?
     GLOBAL upos AS INTEGER             ' line up/down allowed ?

' ********************************************************************************************
' ********************************************************************************************
' ********************************************************************************************
STATIC FUNCTION druke(a$, b$, c$) AS INTEGER
     IF a$ = "" AND c$ = "" THEN
          a$ = "Druk een toets"
     END IF
     r = CURSORY: p = CURSORX
     ee$ = scanline$(a$)
     k = LEN(ee$)
     IF LEN(c$) THEN
          COLOR 15, 0: PRINT c$;: COLOR 7, 0
     END IF
     LOCATE r, p + LEN(a$) + 1
te:
     b$ = UCASE$(inx$)
     IF note THEN
          i = INSTR("&é" + $DQ + "'(§è!çà)$:;", b$)
          IF i THEN
               b$ = MID$("1234567890+*/.", i, 1)
          END IF
     END IF

     IF b$ = CHR$(13) THEN
          b$ = c$
     END IF
     IF k AND INSTR(ee$, b$) = 0 AND b$ <> "*" THEN
          BEEP
          GOTO te
     END IF
     IF LEN(b$) = 1 THEN
          PRINT b$;
     END IF
     druke = b$ = "*"
     LOCATE r, p
     PRINT a$;
END FUNCTION

' ********************************************************************************************
' ********************************************************************************************
' ********************************************************************************************
STATIC FUNCTION inpx (b$, t$, l) AS STRING
     IF l = 0 THEN
          l = LEN(t$)
     END IF
     z = ty
     rr = 0
     uposix = 0
     IF b$ <> "" THEN
          rr = CURSORY: pp = CURSORX
          ee$ = UCASE$(scanline$(b$))
     END IF
     IF upos AND CURSORX > 1 THEN
          uposix = CURSORX - 1
          LOCATE , uposix: COLOR 14, 4 : PRINT CHR$(18);: COLOR 7, 0
          LOCATE , CURSORX
     END IF
     t$ = LEFT$(TRIM$(t$), l)
     r$ = t$
     r = CURSORY
     p = CURSORX
     IF LEN(b$) THEN
          p = p + 1
     END IF
     IF upos <> 0 THEN
         px = ABS(upos) - 1
     END IF
re:
     begin = 1
     IF px > l THEN
          px = l
     ELSEIF px > LEN(t$) THEN
          px = LEN(t$)
     ELSEIF px < 0 THEN
          px = 0
     END IF
     insrt = 0
     GOSUB prline
     DO
          LOCATE r, p + px
          IF insrt THEN
               CURSOR ON, 90
          ELSE
               CURSOR ON, 20
          END IF
          IF z THEN
               ty = z
          END IF
          a$ = inx$
          c = ASC(RIGHT$(a$, 1))
          IF LEN(a$) = 1 THEN
               c = c + 300
          END IF
          IF (a$ = "*" AND px = 0) OR (z AND ty < 0) THEN
               inpx$ = "*"
               upos = 0
               r$ = t$
               EXIT DO
          END IF
          IF (LEN(ee$) <> 0 AND INSTR(ee$, UCASE$(a$)) <> 0 AND begin <> 0) THEN
               inpx = a$
               r$ = a$
               EXIT DO
          END IF
          IF c > 331 THEN
               IF begin AND px = 0 THEN
                    r$ = a$
                    px = 1
                    GOSUB prline
               ELSE
                    COLOR 15, 1: PRINT a$;: COLOR 7, 0
                    IF insrt THEN
                        r$ = LEFT$(LEFT$(r$, px) + a$ + MID$(r$, px + 1), l)
                    ELSE
                        'MID$(r$, px) = a$
                        r$ = LEFT$(r$, px) + a$ + MID$(r$, px + 2)
                    END IF
                    IF px + 1 < l THEN
                         px = px + 1
                    ELSE
                         BEEP
                    END IF
                    IF insrt THEN
                         GOSUB prline
                    END IF
               END IF
          ELSE
              SELECT CASE AS CONST c
              CASE %esc
                   r$ = t$
                   px = 0
                   GOTO re
              CASE %home
                   px = 0
              CASE %back
                   IF px THEN
                        px = px - 1
                   END IF
              CASE %forw
                   IF px < LEN(r$) AND px + 1 < l THEN
                        px = px + 1
                   END IF
              CASE %end
                   px = LEN(r$)
                   IF px + 1 > l THEN
                        px = l - 1
                   END IF
                   IF p + px > 80 THEN
                        px = 80 - p
                   END IF
              CASE %ins
                   insrt = NOT insrt
              CASE %del
                   r$ = LEFT$(r$, px) + MID$(r$, px + 2)
                   GOSUB prline
              CASE %backsp
                   IF px THEN
                        r$ = LEFT$(r$, px - 1) + MID$(r$, px + 1)
                        px = px - 1
                   END IF
                   GOSUB prline
              CASE %y
                   r$ = LEFT$(r$, px)
                   GOSUB prline
              CASE %enter
                   inpx$ = r$
                   upos = 0
                   EXIT DO
              CASE %tab
                   DO
                        c = px
                        i = INSTR(MID$(r$, px + 1), " ") + px
                        IF i = px OR i + 1 >= l THEN
                             px = 0
                        ELSE
                             px = i
                        END IF
                   LOOP UNTIL MID$(r$, px + 1, 1) <> " " OR c = px
              CASE %up, %upn
                   IF upos THEN
                        inpx = r$
                        upos = -px - 1
                        EXIT DO
                   END IF
              CASE %down, %downn
                   IF upos THEN
                        inpx = r$
                        upos = px + 1
                        EXIT DO
                   END IF
              END SELECT
          END IF
          begin = 0
          'LOCATE 10, 1: print "["  r$  "]"
     LOOP
     IF rr THEN
          LOCATE rr, pp
          PRINT b$ + " ";
     END IF
     IF uposix THEN
        LOCATE , uposix: PRINT " ";
     END IF
     LOCATE r, p:
     PRINT r$; SPACE$(l - LEN(r$));
     EXIT FUNCTION

prline:
     LOCATE r, p
     COLOR 15, 1: PRINT r$ + STRING$(l - LEN(r$), 250);: COLOR 7, 0
RETURN
END FUNCTION

' ********************************************************************************************
STATIC FUNCTION inx AS STRING
     IF insr THEN
         insr = 0
         r = CURSORY: p = CURSORX
         LOCATE 2, 59: PRINT SPACE$(19) CHR$(13);
         LOCATE r, p
     END IF
     CURSOR ON
     inx$ = WAITKEY$
     CURSOR OFF
END FUNCTION

' ********************************************************************************************
' ********************************************************************************************
' ********************************************************************************************
STATIC SUB ppp (a$, i, pj)
     l = INSTR(a$, "<")
     c = CHOOSE(i + 1, 7, 15)
     DO WHILE l
         COLOR c, 0
         PRINT LEFT$(a$, l);
         COLOR 14, 1
         r = CURSORY: p = CURSORX
         b$ = MID$(a$, l + 1, INSTR(MID$(a$, 2), ">") - l)
         PRINT b$;
         j = p + LEN(b$)
         k = INSTR(MID$(b$, 2), "/")
         IF k THEN
              k = k + 1
         END IF
         COLOR c, 0
         DO WHILE k
             p = p + k
             LOCATE r, p - 1
             PRINT "/";
             b$ = MID$(b$, k + 1)
             k = INSTR(b$, "/")
         LOOP
         LOCATE r, j
         a$ = MID$(a$, INSTR(MID$(a$, 2), ">") + 1)
         l = INSTR(a$, "<")
     LOOP
     PRINT a$;
     IF pj THEN
          PRINT
     END IF
     COLOR 7, 0
END SUB

' ********************************************************************************************
STATIC FUNCTION scanline (a$) AS STRING
    ff$ = a$: ee$ = ""
    DO
        ff$ = REMAIN$(ff$, "<")
        b$ = EXTRACT$(ff$, ">")
        c = LEN(b$)
        IF c > 1 THEN
            b$ = REMOVE$(b$, "/")
        END IF
        ee$ = ee$ + b$
    LOOP WHILE c
    scanline = ee$
    ppp a$ + " ", 0, 0
END FUNCTION

' ********************************************************************************************
' ********************************************************************************************
' ********************************************************************************************
STATIC FUNCTION setline (file$, text$) AS DWORD
    LOCAL i AS INTEGER
    i = FREEFILE
    OPEN file$ FOR APPEND AS #i
    setline = LOF(i) + 1
    PRINT #i, text$
    CLOSE #i
END FUNCTION

STATIC FUNCTION getline (file$, position AS DWORD) AS STRING
    LOCAL i AS INTEGER, a AS STRING
    i = FREEFILE
    OPEN file$ FOR INPUT AS #i
    SEEK #i, position
    LINE INPUT #i, a$
    getline$ = a$
    CLOSE #i
END FUNCTION

STATIC SUB killline (file$, position AS DWORD)
    LOCAL i AS INTEGER, a AS STRING
    i = FREEFILE
    OPEN file$ FOR INPUT AS #i
    SEEK #i, position
    LINE INPUT #i, a$
    CLOSE #i
    OPEN file$ FOR BINARY AS #i
    SEEK #i, position
    PUT$ #i, SPACE$(LEN(a$))
    CLOSE #i
END SUB

' ********************************************************************************************
STATIC SUB writeerr(a$)
   DIM ffi AS INTEGER
   ffi = FREEFILE
   OPEN "c:\err.txt" FOR APPEND AS #ffi
   PRINT #ffi, DATE$  " "  TIME$ + a$
   CLOSE #ffi
END SUB

' ********************************************************************************************
STATIC FUNCTION getdata (c$, b$) AS STRING
   getdata$ = ""
   IF b$ = EXTRACT$(c$, "=") THEN
      getdata$ = EXTRACT$(REMAIN$(c$, "="), " ;")
   END IF
END FUNCTION

' ********************************************************************************************
' ********************************************************************************************
' ********************************************************************************************
STATIC FUNCTION getval(a$, b$) AS STRING
   getval$ = ""
   ON ERROR GOTO nofileval
   z = FREEFILE: OPEN a$ FOR INPUT ACCESS READ SHARED AS #z
   WHILE NOT EOF(z)
      LINE INPUT #z, c$
      i = INSTR(c$, "=")
      IF i THEN
         IF b$ = EXTRACT$(MID$(c$, i + 1), " ;") THEN
             getval$ = LEFT$(c$, i - 1)
             GOTO exval
         END IF
      END IF
   WEND
exval:
   CLOSE #z
   EXIT FUNCTION
nofileval:
   c$ = STR$(ERRCLEAR) + " Getval file: " + a$
   CALL writeerr(c$)
   getval$ = "*" + c$
   RESUME exval
END FUNCTION

' *******************************************************************************************
' *******************************************************************************************
' *******************************************************************************************
STATIC FUNCTION getini (a$, b$) AS STRING        'a$: filename, b$: parameter (key)
   getini$ = ""
   ON ERROR GOTO nofileget
   z = FREEFILE: OPEN a$ FOR INPUT ACCESS READ SHARED AS #z
   WHILE NOT EOF(z)
      LINE INPUT #z, c$
      c$ = getdata$(c$, b$)
      IF c$ <> "" THEN
         getini$ = TRIM$(c$)
         CLOSE #z
         EXIT FUNCTION
      END IF
   WEND
exget:
   CLOSE #z
   EXIT FUNCTION
nofileget:
   c$ = STR$(ERRCLEAR) + " Getini file: " + a$
   CALL writeerr(c$)
   getini$ = "*" + c$
   RESUME exget
END FUNCTION

' ********************************************************************************************
' ********************************************************************************************
' ********************************************************************************************
STATIC SUB setini(a$, b$, c$)
   ON ERROR GOTO nofileset
   z = FREEFILE: OPEN a$ FOR INPUT ACCESS READ SHARED AS #z
   a = -1: c = LEN(c$)
   y$ = LEFT$(a$, LEN(a$) - 4) + "."
   backup$ = y$ + "000"
   y$ = y$ + "tmp"

   y = FREEFILE: OPEN y$ FOR OUTPUT ACCESS WRITE LOCK READ WRITE AS #y
   WHILE NOT EOF(z)
      LINE INPUT #z, d$
      ee$ = getdata$(d$, b$)
      IF ee$ = "" THEN
         PRINT #y, d$
      ELSE
         a = 0
         IF c THEN
             PRINT #y, b$; "="; c$
         END IF
      END IF
   WEND
   IF a AND c THEN
       PRINT #y, b$ "=" c$
   END IF
okset:
   CLOSE z, y
rekill:
   OPEN backup$ FOR APPEND AS #z
   CLOSE #z
   KILL backup$
   NAME a$ AS backup$
   NAME y$ AS a$
exset:
   CLOSE z, y
   EXIT SUB
nofileset:
   CALL writeerr("Setini: " + STR$(ERRCLEAR) + " File: " + a$ + "(" + FORMAT$(a, "") + ")")
   RESUME exset
END SUB