* PX.BACKSRV
* Pixie general purpose BackServer
*
* Copyright © 2001 Pixieware Software (NZ). 
* Pixieware grants the Pixieware Licencee a royalty-free licence to use,  
* copy or modify this Software provided that this copyright notice appears 
* in its entirety on all copies and modifications made. This Software may be 
* modified or copied and distributed under the terms of the Pixie Public Licence. 
* Full Pixie Public Licence online at http://www.pixieware.com/qpl.htm
* In brief, Pixieware requires that if substantial modifications have been 
* applied to the Software , then a copy of the Software and modifications 
* shall be passed back to Pixieware.  Such modifications may subsequently 
* be made available under the Pixie Public Licence when incorporated into
* future versions of the Software.   
* Copies of the modified Software must be sent to: sales@pixieware.com
*
* Started 010328 JPC John Calder
*
* 011109 JPC additional value = conversion code added to <&Q.COLS> feedback
* 011107 JPC standardise on <ERROR> prefix for all error messages
* 011101 JPC fix ID.WHO stray AM side-effect of CAPTURING
* 011031 JPC bULTPLUS flag
* 011031 JPC Fix "</T X B>", "</T":"XB>" ie must represent indirectly
* 011025 JPC EXECUTEPS^WHO
* 011019 JPC FIX to Query to give ItemID as first attribute of each
*  returned item line.
* 011018 JPC Query using dictionary items as extension to ROWSET
* 011004 JPC keyword OPEN
* 011004 JPC CAPTURING command as variation on TCL for fast querying
* 011004 JPC EXECUTEPS use space as delimiter for all operations.
* 010920 JPC Custom PX.LOCK for non-persistent use
*
* Set bPICK = 1 for PICK, bPICK = 0 for UNIVERSE/U2/General use
* Can also be changed on the fly with its "PICK" keyword
*   PICK^1</T X B> - to switch PICK mode on
*   PICK^0</T X B> - to switch PICK mode off
* ..where "^" here and below represents CHAR(254) and the ending tag
* is mis-represented by T X B to prevent this comment from interfering
* with operations.
*
bULTPLUS = 0
bPICK = 0
*
* JPC Difference between UNIVERSE/GENERAL and  PICK config
*===============================================================
* Use of CRT for output works when the server gives direct output
* of reserved characters eg CHAR(254).  UNIVERSE / U2 do this.
* PICK normally changes such characters eg CHAR(254) becomes "^",
* so for PICK servers we need to use special code for direct output:
* eg hX = OCONV(sMyOutput, "u017e")
*
* Request Format is dynamic variable.
* eg
* READ^cust^MacBeth^7^LOCK</T X B>  
*   --> READVU sResponse FROM FV(iFv), "MacBeth", 7
*
* WRITE^cust^MacBeth^^<&IM>AA^BB^CC^DD</T X B>
*   --> WRITE "AA^BB^CC^DD" ON FV(iFv), "MacBeth"
*
* ROWSET^cust^SELECT cust WITH A14 = "[orange]"^</T X B>
*   --> dialog return with entire item
*
* EXECUTEPS^SYSTEM^userinst^locktimeout^</T X B>
*
* RELEASE^myfile^myitemid^</T X B>
*
*   sRequest<1> = Keyword
*   sRequest<2> = FileName(Table Name)
*   sRequest<3> = ItemID(Primary Key value, unique identifier)
*   sRequest<4> = Attribute number(field number), "" means all attributes/fields
*   sRequest<5> = "LOCK" or ""
* THEN "<&IM>" as tag separator if there is data to write.  
* WRITE Request format overview:  sRequest<&IM>sData</T X B>
*
* ROWSET examples:
* (1) direct read from file of attributes 0,3,4,5,8,9
* ROWSET^MYFILE^^0]3]4]5]8]9</T X B>
* (2) read raw data but select particular records
* ROWSET^MYFILE^SELECT MYFILE WITH A0 = "KR]"^0]1]2]3]4]5]6]7</T X B>
* (3) run dictionary-driven query
* ROWSET^MYFILE^SELECT MYFILE WITH DATE GT 10/7/1999^LIST MYFILE A0 A2 DATE</T X B>
*
* Cache FILEVARIABLES and map to FILE NAMES
  DIM FV(200)
  sdFvRef = ""
*
* CONSTANTS
  EQUATE AM TO CHAR(254)
  EQUATE VM TO CHAR(253)
  EQUATE SVM TO CHAR(252)
  EQUATE SSVM TO CHAR(251)
  EQUATE QM TO CHAR(250)
  PROMPT ""
  
* Confirm start OK
  ECHO OFF
  CRT "<T":"XA><START></T":"XA>"

* UserInst
  EXECUTE "WHO" CAPTURING ID.WHO
  *011101 JPC - fix ID.WHO stray AM side-effect of CAPTURING
  ID.WHO = ID.WHO<1>
  USERINST = FIELD(ID.WHO, " ", 2):"*":FIELD(ID.WHO, " ", 1)
  ACCOUNT = FIELD(ID.WHO, " ", 3)
  LOCKTIMEOUT = 0
* Establish Alternative Locks
  B.PERMIT.ALT.LOCKS = 1
  OPEN "PX.LOCKS" TO F.PX.LOCKS ELSE
    B.PERMIT.ALT.LOCKS = 0
  END
* 
* Main loop polls for command sets
  LOOP
    sRequest = ""
    * Allow for limited buffer size when writing-in data
    * MV engines will take requests in chunks 128 - 4096 bytes
    LOOP
      INPUT s
      IF bULTPLUS THEN
        CONVERT CHAR(126) TO CHAR(254) IN s
        CONVERT CHAR(125) TO CHAR(253) IN s
        CONVERT CHAR(124) TO CHAR(252) IN s
        CONVERT CHAR(123) TO CHAR(251) IN s
      END
      *** N.TXBS = INDEX(s, "<T":"XB>", 1)
      *** IF N.TXBS GT 0 THEN s = s[N.TXBS+5,999999]  
      N.TXBE = INDEX(s, "</T":"XB>", 1)
      IF N.TXBE GT 0 THEN
        sRequest := s[1, N.TXBE-1]
        EXIT
      END ELSE
        sRequest := s
        CRT "<T":"XA><NEXT></T":"XA>"
      END
    REPEAT
    BEGIN CASE
    CASE sRequest<1> = "READ"
      GOSUB OOPEN
      IF bOpen THEN GOSUB RREAD
    CASE sRequest<1> = "WRITE"
      GOSUB OOPEN
      IF bOpen THEN GOSUB WWRITE
    CASE sRequest<1> = "ROWSET"
      GOSUB OOPEN
      IF bOpen THEN GOSUB ROWSET
    CASE sRequest<1> = "OPEN"
      GOSUB OOPEN
      IF bOpen THEN CRT "<T":"XA>OK</T":"XA>"
    CASE sRequest<1> = "EXECUTE"
      EXECUTE sRequest<2>
    CASE sRequest<1> = "TCL"
      CRT "<T":"XC>":
      EXECUTE sRequest<2>
      CRT "</T":"XC>"
    CASE sRequest<1> = "CAPTURING"
      EXECUTE sRequest<2> CAPTURING S
      CRT "<T":"XA>":S:"</T":"XA>"
    CASE sRequest<1> = "EXECUTEPS"
      GOSUB EXECUTEPS
      *CRT reply is built into gosubroutine
    CASE sRequest<1> = "PICK"
      bPICK = sRequest<2>
      CRT "<T":"XA>OK</T":"XA>"
    CASE sRequest<1> = "ULTPLUS"
      bULTPLUS = sRequest<2>
      CRT "<T":"XA>OK</T":"XA>"      
    CASE sRequest<1> = "RELEASE"
      IF LOCKTIMEOUT + 0 GT 0 THEN
        GOSUB ARELEASE
      END ELSE
        *traditional RELEASE
        IF sRequest<2> GT "" THEN
          LOCATE sRequest<2> IN sdFvRef SETTING iFV THEN
            IF sRequest<3> GT "" THEN
              RELEASE FV(iFv), sRequest<3>
            END ELSE
              RELEASE
              *RELEASE FV(iFv)
            END
          END ELSE
            RELEASE 
          END
        END ELSE
          RELEASE
        END
      END
      CRT "<T":"XA>OK</T":"XA>" 
    CASE sRequest<1> = "DELETE"
      *<todo> check for locking first
      GOSUB OOPEN
      IF bOpen THEN DELETE FV(iFv), sRequest<3>
      CRT "<T":"XA>OK</T":"XA>"
    CASE sRequest<1> = "EXIT"
      CRT "<T":"XA><END></T":"XA>"
      STOP
    CASE 1
      CRT "<T":"XA><ERROR>[915] Keyword ":sRequest<1>:" not recognised.</T":"XA>"
    END CASE
  REPEAT
*----------------------------------------------
*KEYWORDS SECTION: READ, WRITE, ROWSET, 
*----------------------------------------------
*
RREAD:
  IF sRequest<5> = "LOCK" AND LOCKTIMEOUT = 0 THEN
    * Traditional locking
    IF sRequest<4> = "" THEN
      READU sResponse FROM FV(iFv), sRequest<3> LOCKED CRT "<T":"XA><ERROR>[920] Record locked</T":"XA>" ; RETURN ELSE
        CRT "<T":"XA><ERROR>[912] READU ERROR</T":"XA>"
        RETURN
      END
    END ELSE
      READVU sResponse FROM FV(iFv), sRequest<3>, sRequest<4> LOCKED CRT "<T":"XA><ERROR>[920] Record locked</T":"XA>" ; RETURN ELSE
        CRT "<T":"XA><ERROR>[912] READVU ERROR</T":"XA>"
        RETURN
      END
    END
  END ELSE
    IF (LOCKTIMEOUT + 0 > 0) AND (sRequest<5> = "LOCK") THEN
      *Check PX.LOCKS first and then use READ or READV
      READ SD.LOCK FROM F.PX.LOCKS, sdFvRef<iFV>:" ":sRequest<3> THEN
        IF SD.LOCK<1> <> USERINST THEN
          IF SD.LOCK<2> LE DATE() + (TIME() - LOCKTIMEOUT)/86440 THEN
            *We are locked out
            CRT "<T":"XA><ERROR>[920] Record locked</T":"XA>"
            RETURN
          END
        END
      END
      *No lock, or our lock, or expired lock, so we can proceed 
      *with taking possession with our own lock
      SD.LOCK = ""
      SD.LOCK<1> = USERINST
      SD.LOCK<2> = DATE() + TIME()/86440
      WRITE SD.LOCK ON F.PX.LOCKS, sdFvRef<iFV>:" ":sRequest<3>
    END
    IF sRequest<4> = "" THEN
      READ sResponse FROM FV(iFv), sRequest<3> ELSE
        CRT "<T":"XA><ERROR>[912] READ ERROR</T":"XA>"
        RETURN
      END
    END ELSE
      READV sResponse FROM FV(iFv), sRequest<3>, sRequest<4> ELSE
        CRT "<T":"XA><ERROR>[912] READV ERROR</T":"XA>"
        RETURN
      END
    END
  END
  *010426 JPC configure for PICK/U2
  IF bPICK THEN
    hX = OCONV("<T":"XA>":sResponse:"</T":"XA>", "u017e")
  END ELSE
    CRT "<T":"XA>":sResponse:"</T":"XA>"
  END
  RETURN
*----------------------------------------------
*
WWRITE:
  iPos = INDEX(sRequest, "<&IM>", 1)
  sData = sRequest[iPos+5, 999999]
  sRequest = sRequest[1, iPos-1]
  IF sRequest<5> = "LOCK" AND LOCKTIMEOUT = 0 THEN
    * Traditional locking
    IF sRequest<4> = "" THEN
      WRITEU sData ON FV(iFv), sRequest<3>
    END ELSE
      WRITEVU sData ON FV(iFv), sRequest<3>, sRequest<4>
    END
  END ELSE
    IF LOCKTIMEOUT + 0 > 0 THEN
      *Check PX.LOCKS first and then use WRITE or WRITEV
      READ SD.LOCK FROM F.PX.LOCKS, sdFvRef<iFV>:" ":sRequest<3> THEN
        IF SD.LOCK<1> <> USERINST THEN
          IF SD.LOCK<2> LE DATE() + (TIME() - LOCKTIMEOUT)/86440 THEN
            *We are locked out
            CRT "<T":"XA><ERROR>[920] Record locked</T":"XA>"
            RETURN
          END
        END
      END
      *No lock, or our lock, or expired lock, so we can proceed 
      IF sRequest<5> = "LOCK" THEN 
        * WRITEU, WRITEVU so renew the lock
        SD.LOCK<1> = USERINST
        SD.LOCK<2> = DATE() + TIME()/86440
        WRITE SD.LOCK ON F.PX.LOCKS, sdFvRef<iFV>:" ":sRequest<3>
      END ELSE
        * release the lock
        DELETE F.PX.LOCKS, sdFvRef<iFV>:" ":sRequest<3>
      END
    END
    *end of custom alternative lock handler for WRITE etc
    *
    IF sRequest<4> = "" THEN
      WRITE sData ON FV(iFv), sRequest<3>
    END ELSE
      WRITEV sData ON FV(iFv), sRequest<3>, sRequest<4> 
    END
  END
  CRT "<T":"XA>OK</T":"XA>"
  RETURN  
*----------------------------------------------
*
ROWSET:
  Q.LIST = TRIM(sRequest<4>)
  IF Q.LIST = "" THEN
    nCHUNK = 10
  END ELSE
    IF Q.LIST = "0" THEN nCHUNK = 100 ELSE nCHUNK = 20
  END
  IF sRequest<3> NE "" THEN
    EXECUTE sRequest<3>
  END ELSE
    SELECT FV(iFv)
  END
  * Start dialog with client, rows to output in batches of 10
  CRT "<T":"XA>ROWSET START</T":"XA>"
  INPUT sHandshake
  *011017 JPC Q.COLS builds column info for Excel etc
  Q.COLS = ""
  Q.SPECS = ""
  N.COLS = 0
  IF Q.LIST[1,5] = "LIST " THEN
    OPEN "DICT ":FIELD(Q.LIST, " ", 2) TO F.DICT ELSE
      CRT "<T":"XA><ERROR>[914] Open fails for 'DICT ":FIELD(Q.LIST, " ", 2):"'</T":"XA>"
      RETURN
    END
    N.COLS = DCOUNT(Q.LIST, " ") - 2
    IF N.COLS GE 1 THEN
      Q.SPECS = "ItemID"
      FOR iC = 1 TO N.COLS
        READ Q.SPEC FROM F.DICT, FIELD(Q.LIST, " ", iC + 2) ELSE Q.SPEC = ""
        Q.SPECS := QM:Q.SPEC
        Q.COLS<iC+1> = Q.SPEC<3>:QM:Q.SPEC<9>:Q.SPEC<10>:QM:Q.SPEC<7>
      NEXT iC
    END ELSE
      * Cover case of "LIST MYFILE" where DICT MYFILE has default items 1, 2, 3, ...
      N.NOSPEC = 0
      iC = 0
      FOR i = 1 TO 500
        READ Q.SPEC FROM F.DICT, i THEN
          iC = iC + 1
          IF iC = 1 THEN 
            Q.SPECS = "ItemID":QM:Q.SPEC 
          END ELSE 
            Q.SPECS := QM:Q.SPEC
          END
          Q.COLS<iC+1> = Q.SPEC<3>:QM:Q.SPEC<9>:Q.SPEC<10>:QM:Q.SPEC<7>
        END ELSE
          N.NOSPEC = N.NOSPEC + 1
          *Some MVs don't offer EXIT from FOR so subst this GOTO  
          IF N.NOSPEC = 4 THEN GOTO FOREXIT1
        END
      NEXT i
FOREXIT1:
      N.COLS = iC
    END
    IF Q.COLS GT "" THEN
      *011018 JPC Inform client, especially Excel, of row-layout info in dict
      *The "<&Q.COLS>" tag signals PixieWeb to store this in SelectArray row 0
      IF bPICK THEN
        hX = OCONV("<T":"XA>":"<&Q.COLS>":Q.COLS:"</T":"XA>", "u017e")
      END ELSE
        CRT "<T":"XA>":"<&Q.COLS>":Q.COLS:"</T":"XA>"
      END
      INPUT sHandshake
      IF sHandshake = "QUIT" THEN
        CRT "<T":"XA>ROWSET EXIT</T":"XA>"
        RETURN
      END   
    END
  END
*
  LOOP
    sTX = ""
    sItem = ""
    FOR iBlock = 1 TO nCHUNK
      READNEXT sID ELSE 
        IF sTX > "" THEN
          *010426 JPC configure for PICK/U2
          IF bPICK THEN
            hX = OCONV("<T":"XA>":sTX:"</T":"XA>", "u017e")
          END ELSE
            CRT "<T":"XA>":sTX:"</T":"XA>"
          END
        END
        ** 000130 JPC allow for count is a multiple of nCHUNK
        IF iBlock > 1 THEN INPUT sHandshake
        CRT "<T":"XA>ROWSET EXIT</T":"XA>"
        RETURN
      END
      IF Q.LIST NE "0" THEN
        READ sItem FROM FV(iFv), sID ELSE
          CRT "<T":"XA><ERROR>[914] Item ":sID:" not found</T":"XA>"
          RETURN
        END
      END
      IF Q.LIST GT "" THEN
        *011017 JPC coded equivalent to LIST
        *NOTE sTemp required here because it selects (and converts)
        *from a previously READ sItem
        IF Q.LIST[1,5] = "LIST " THEN
          sTemp = sID
          *011019 JPC FIX to ensure 1st returned attribute is sID ie ItemID
          FOR iC = 1 TO N.COLS
            Q.VAL = ""
            Q.SPEC = FIELD(Q.SPECS, QM, iC+1)
            BEGIN CASE
            CASE Q.SPEC<1> = "A"
              Q.VAL = sItem<Q.SPEC<2>>
              IF Q.SPEC<8> GT "" THEN Q.VAL = OCONV(Q.VAL, Q.SPEC<8>)
              IF Q.SPEC<7> GT "" THEN Q.VAL = OCONV(Q.VAL, Q.SPEC<7>)                
            CASE Q.SPEC<1> = "S"
              Q.VAL = ""
              IF Q.SPEC<8> GT "" THEN Q.VAL = OCONV(Q.VAL, Q.SPEC<8>)
              IF Q.SPEC<7> GT "" THEN Q.VAL = OCONV(Q.VAL, Q.SPEC<7>)
            END CASE
            sTemp<iC+1> = Q.VAL
          NEXT iC
        END ELSE
          *PixieWeb raw values select by list of attribute numbers
          sTemp = ""
          FOR iC = 1 TO DCOUNT(Q.LIST, VM)
            IF Q.LIST<1,iC> = 0 THEN
              sTemp<iC> = sID
            END ELSE
              sTemp<iC> = sItem<Q.LIST<1,iC>>
            END  
          NEXT iC
        END
        sItem = sTemp
      END ELSE
        sItem = sID:CHAR(254):sItem
      END
      IF sTX > "" THEN
        sTX := "<&IM>":sItem
      END ELSE
        sTX = sItem
      END
    NEXT iBlock
    *010426 JPC configure for PICK/U2
    IF bPICK THEN
      hX = OCONV("<T":"XA>":sTX:"</T":"XA>", "u017e")
    END ELSE
      CRT "<T":"XA>":sTX:"</T":"XA>"
    END
    INPUT sHandshake
    IF sHandshake = "QUIT" THEN EXIT
  REPEAT 
  CRT "<T":"XA>ROWSET EXIT</T":"XA>"
  RETURN

*==============================================
*END of keywords section
*----------------------------------------------
OOPEN:
  bOpen = 1
  LOCATE sRequest<2> IN sdFvRef SETTING iFv ELSE
    b = 0
    n = DCOUNT(sdFvRef, CHAR(254))
    * some MVs can not EXIT a FOR..NEXT, so build as LOOP..REPEAT
    i = 0
    LOOP
      i = i + 1
      IF sdFvRef<i> = "" THEN
        b = 1
        iFv = i
        EXIT
      END
      IF i = n THEN EXIT
    REPEAT
    IF b = 0 THEN iFv = n + 1
    OPEN sRequest<2> TO FV(iFv) ELSE
      bOpen = 0
      CRT "<T":"XA><ERROR>[911] File '":sRequest<2>:"' fails to OPEN so may not exist.</T":"XA>"
      RETURN
    END
    sdFvRef<iFv> = sRequest<2>
  END
  RETURN
*-----------------------------------------------
*Custom execute of some coded common operations with
*extra information feeding back.  
EXECUTEPS:  
  BEGIN CASE
  CASE sRequest<2> = "ACCOUNT"
    CRT "<T":"XA>": FIELD(ID.WHO, " ", 3) :"</T":"XA>"
  CASE sRequest<2> = "WHO"
      CRT "<T":"XA>":ID.WHO:"</T":"XA>"
  CASE FIELD(sRequest<2>, " ", 1) = "SYSTEM"
    BEGIN CASE
    CASE FIELD(sRequest<2>, " ", 2) = "USERINST"
      IF FIELD(sRequest<2>, " ", 3) = "" THEN
        CRT "<T":"XA>":USERINST:"</T":"XA>"
      END ELSE
        USERINST = FIELD(sRequest<2>, " ", 3)
        CRT "<T":"XA>OK</T":"XA>"
      END
    CASE FIELD(sRequest<2>, " ", 2) = "LOCKTIMEOUT"
      IF FIELD(sRequest<2>, " ", 3) = "" THEN
        CRT "<T":"XA>":LOCKTIMEOUT:"</T":"XA>"
      END ELSE
        * Did we open PX.LOCKS ?
        IF NOT(B.PERMIT.ALT.LOCKS) THEN
          CRT "<T":"XA><ERROR></T":"XA>"
          RETURN
        END
        LOCKTIMEOUT = FIELD(sRequest<2>, " ", 3)
        CRT "<T":"XA>OK</T":"XA>"
      END
    END CASE

  CASE 1
    *Unknown commands, handover to PICK etc
    CRT "<T":"XA>":
    EXECUTE sRequest<2>
    CRT "</T":"XA>":
  END CASE
  RETURN
  
*-------------------------------------------
*Custom alternative locking: RELEASE
*
ARELEASE:
  IF sRequest<2> GT "" AND sRequest<3> GT "" THEN
    DELETE F.PX.LOCKS, sRequest<2>:" ":sRequest<3>
  END ELSE
    SELECT F.PX.LOCKS
    LOOP
      READNEXT ID.LOCK ELSE EXIT
      READ SD.LOCK FROM F.PX.LOCKS, ID.LOCK THEN
        IF USERINST = SD.LOCK<1> THEN
          BEGIN CASE
          CASE sRequest<3> GT ""
            IF sRequest<2>:" ":sRequest<3> = ID.LOCK THEN
              DELETE F.PX.LOCKS, ID.LOCK
            END
          CASE sRequest<2> GT ""
            IF FIELD(ID.LOCK, " ", 1) = sRequest<2> THEN
              DELETE F.PX.LOCKS, ID.LOCK
            END   
          CASE 1
            DELETE F.PX.LOCKS, ID.LOCK
          END CASE
        END
      END
    REPEAT
  END
  RETURN 
  
*END OF PX.BACKSRV