      ************************************************************************
      * Copyright (C) 1999 Micro Focus International Ltd.
      * All rights reserved.
      *  
      * This demonstration program is provided for use by users of 
      * Micro Focus products (the "Software") and may be used, 
      * modified and distributed as part of your application provided 
      * that you properly acknowledge the copyright of Micro Focus in this
      * material.
      *     
      * All conditions, warranties and undertakings, express or implied, 
      * statutory or otherwise, on the part of Micro Focus are excluded, 
      * including without limitation those of merchantability or fitness  
      * for purpose. This shall not, however, purport to exclude or 
      * restrict the liability of Micro Focus to any extent not 
      * permitted by law.
      *
      * IN NO EVENT WILL MICRO FOCUS BE LIABLE FOR ANY INDIRECT, 
      * INCIDENTAL, SPECIAL, CONSEQUENTIAL OR OTHER DAMAGES ARISING OUT 
      * OF THE USE OF THE DEMONSTRATION PROGRAM DISTRIBUTED WITH THE 
      * SOFTWARE, WHETHER OR NOT INFORMED OF THE POSSIBILITIES OF 
      * DAMAGES IN ADVANCE.  THESE LIMITATIONS APPLY TO ALL CAUSES OF 
      * ACTION, INCLUDING BREACH OF CONTRACT, BREACH OF WARRANTY, STRICT
      * LIABILITY, AND ANY ACTIONS IN TORTS.
      ************************************************************************
      * This module provides basic functions for server side persistence
      * for COBOL CGI applications. Please feel free to use this as a
      * template to produce a more advanced version of any functionality
      * which you might require.
      *
      * Possible enhancements may include -
      *  o Passing back encrypted keys
      *  o Better key management
      *
      * Description: Server Side Persistence functions.
      *
      *****************************************************************
      * Uncomment the next line for compiling under non threaded applications
      *> $set constant nothread(1)
      $IF NOTHREAD NOT DEFINED
      $set reentrant(1) case
      $END
      $set retrylock optional-file
      $set constant KEY-LEN(30)
      $set constant DATE-LEN(21)
      $set constant KEY-DATE-LEN(51)
      $set constant DATA-LEN(63000)
       identification division.
       program-id. sstate.
       environment division.
       input-output section.
       file-control.
           select server-state assign to sstate-name
           organization is indexed
           access mode is dynamic
           lock mode is automatic
           with lock on multiple records
           record key is client-id-key
           file status is file-status.

      * records are locked on READ and released on CLOSE
      * This program trys to ensure the client-id keys will
      * be unique using this mechanism.
      
       data division.
       file section.
       fd server-state 
      $IF NOTHREAD NOT DEFINED
                       thread-local
      $END
           record varying from 52 to 63052 depending on fd-rec-size
           recording mode is v.
       01 server-record.
          03 client-id-key pic x(KEY-LEN).
          03 client-date   pic x(DATE-LEN).
          03 client-data   pic x(DATA-LEN).

       01 filler.
          03 filler         pic x(KEY-DATE-LEN).
          03 client-data-id pic xxxx comp-x.

       working-storage section.
       01 day-list.
          03 filler pic x(21) value "MonTueWedThuFriSatSun".
       01 day-table redefines day-list occurs 7 times.
          03 day-text    pic x(3).

       01 month-list.
          03 filler pic x(36) value
                                "JanFebMarAprMayJunJulAugSepOctNovDec".
       01 month-table redefines month-list occurs 12 times.
          03 month-text    pic x(3).

       78 day-reference value  144642. *>  6th January  1997 Monday
       78 MAX-DAYS      value 3067671. *> 31st December 9999

      $IF NOTHREAD NOT DEFINED
       thread-local-storage section.
      $END NOTHREAD
       01 sstate-name pic x(255).
       01 fd-rec-size pic xxxx comp-x.
       01 file-status.
          03 fs-1 pic x.
          03 fs-2 pic x.
          03 fs-2x redefines fs-2 pic x comp-x.
      
      * Common file errors we may encounter
      * 05 OPEN  optional file does not exists at time of OPEN statement
      * 22 WRITE duplicate key
      * 23 READ  no record found
      * 35 OPEN  optional-file directive required (on UNIX)
      * 41 OPEN  file already open
      * 9A OPEN  file locked
      * 9D REWRITE record locked

       01 file-mode      pic x comp-x value 0.
       78 file-closed    value 0.
       78 file-open      value 1.
       01 client-id      pic xxxx comp-x.

       01 server-date.
          03 d-year  pic 9999.
          03 d-month pic 99.
          03 d-day   pic 99.
          03 d-hour  pic 99.
          03 d-min   pic 99.
          03 d-sec   pic 99.
          03 d-hsec  pic 99.
          03 d-gmt   pic x.
          03 d-hgmt  pic 99.
          03 d-mgmt  pic 99.

       01 yyyymmdd-date.
          03 d-year  pic 9999.
          03 d-month pic 99.
          03 d-day   pic 99.
       01 yyyymmdd-num pic 99999999 redefines yyyymmdd-date.
          
       01 days-01       pic xxxx comp-x.
       01 days-02       pic xxxx comp-x.
       01 days-03       pic xxxx comp-x.
       01 expiry-string pic x(50).
       
       linkage section.
       01 lk-client-id       pic x(KEY-LEN).
       01 lk-client-data     pic x.
       01 lk-client-data-len pic xxxx comp-x.
       01 lk-status          pic x comp-x.

      * 0 All operations okay 
      * 1 Any error during a file operation READ/REWRITE/OPEN
      * 2 Duplicate Key found
      * 3 Key not found
      * 4 Length too big Max 63000    NB Max FD size is 63488

       01 lk-sstate-name pic x(255).
       01 lk-days        pic xxxx comp-x.
       01 lk-expiry      pic x(50).
       procedure division.
           exit program
           .

       entry "MF_CLIENT_STATE_FILE" using lk-sstate-name
                                          lk-status.
           move lk-sstate-name to sstate-name
           move 0 to lk-status
           exit program
           .

       entry "MF_CLIENT_STATE_ALLOCATE" using lk-client-id
                                              lk-client-data-len
                                              lk-status.

           if lk-client-data-len > DATA-LEN
               move 4 to lk-status
               exit program
           end-if

           move lk-client-id to client-id-key
           open i-o server-state              *> file locked ?
           if file-status = "41"              *> file already open
                move "00" to file-status
           end-if
           perform check-file-status
           if lk-status not = 0
               exit program
           end-if
      *    if file-status = "9A" *> file locked. This should not happen.
      *        exit program
      *    end-if

           if client-id-key = space 
      * update internal key           
               move 0 to client-id-key
      * This read statement will not cause a lock to happen if this is the
      * first time , ie the OPEN gave a "05"
               read server-state *> automatically locked record
               move function current-date to client-date
               if file-status = "23"
                   move 1 to client-data-id
                   move KEY-DATE-LEN TO fd-rec-size
                   add length of client-data-id to fd-rec-size
                   write server-record
               else
                   add 1 to client-data-id
                   rewrite server-record
               end-if
               move client-data-id to client-id-key
               move client-id-key to lk-client-id
           end-if
      * allocate record
           move KEY-DATE-LEN TO fd-rec-size
           add lk-client-data-len to fd-rec-size
           move function current-date to client-date
           move space to client-data(1:fd-rec-size)
           write server-record
           perform check-file-status
           close server-state
           move file-closed to file-mode
           exit program
           .

       entry "MF_CLIENT_STATE_RESTORE" using lk-client-id
                                             lk-client-data
                                             lk-client-data-len
                                             lk-status.
           move lk-client-id to client-id-key
           perform check-open-file
           read server-state 
           perform check-file-status
           if lk-status = 0
               subtract KEY-DATE-LEN from fd-rec-size
               move client-data(1:fd-rec-size)
                    to lk-client-data(1:lk-client-data-len)
               move fd-rec-size to lk-client-data-len
           end-if
           exit program
           .

       entry "MF_CLIENT_STATE_SAVE" using lk-client-id
                                          lk-client-data
                                          lk-client-data-len
                                          lk-status.

           if lk-client-data-len > DATA-LEN
               move 4 to lk-status
               exit program
           end-if
           move lk-client-id to client-id-key
           move lk-client-data-len to fd-rec-size
           move lk-client-data(1:fd-rec-size) to client-data
           perform check-open-file
           add KEY-DATE-LEN to fd-rec-size
           move function current-date to client-date
           rewrite server-record 
           perform check-file-status
           close server-state                  *> release record lock 
           move file-closed to file-mode
           exit program
           .

       entry "MF_CLIENT_STATE_DELETE" using lk-client-id
                                            lk-status.
           move lk-client-id to client-id-key
           perform check-open-file
           delete server-state record
           perform check-file-status
           exit program
           .

      * Delete all records older than x days.
       entry "MF_CLIENT_STATE_PURGE" using lk-days
                                           lk-status.                       
           move lk-days to days-01
           if file-mode = file-open
               close server-state
               move file-closed to file-mode
           end-if
           open i-o server-state
           perform check-file-status
           if lk-status not = 0
               exit program
           end-if
      * skip first record
           read server-state next
           perform check-file-status
           if lk-status not = 0
               exit program
           end-if
           move function current-date to server-date
           move corr server-date to yyyymmdd-date
           move function integer-of-date(yyyymmdd-num) to days-02
           subtract days-01 from days-02
           perform until exit
               read server-state next 
                   at end 
                       exit perform
               end-read
               move client-date to server-date
               move corr server-date to yyyymmdd-date
               move function integer-of-date(yyyymmdd-num) to
                           days-03
               if days-02 >= days-03
                   delete server-state record
               end-if
           end-perform
           close server-state
           exit program
           .

      * Contruct a cookie expiry date x number of days after today.
       entry "MF_CLIENT_STATE_EXPIRY" using lk-days 
                                            lk-expiry.
           move lk-days to days-01
           move function current-date to server-date
           move corr server-date to yyyymmdd-date
           move function integer-of-date(yyyymmdd-num) to days-02
           add days-01 to days-02
           if days-02 > MAX-DAYS
               move MAX-DAYS to days-02
           end-if
           move function date-of-integer(days-02) to yyyymmdd-num
           subtract day-reference from days-02
      * Monday = 0
           divide days-02 by 7 giving days-01 remainder days-03
      * Format is - day, dd-month-yyyy hh:mm:ss GMT
      * html portion would be .. expires=%%!s expstr%%  ..

           add 1 to days-03
           string day-text(days-03) ", "
                  d-day of yyyymmdd-date "-"
                  month-text(d-month of yyyymmdd-date) "-"
                  d-year of yyyymmdd-date " "
                  d-hour ":" d-min ":" d-sec " GMT"
              delimited by size
              into expiry-string
           move expiry-string to lk-expiry
           exit program
           .
          
       check-open-file section.
           if file-mode not = file-open
               open i-o server-state
               move file-open to file-mode
           end-if
           .

       check-file-status section.
           if fs-1 not = "0"
               evaluate file-status
               when "22"                *> Duplicate key on WRITE
                   move 2 to lk-status
               when "23"                *> Key not found on READ/REWRITE
                   move 3 to lk-status
               when other               *> Something else
                   move 1 to lk-status
               end-evaluate
           else
               move 0 to lk-status
           end-if
           .

       end program sstate.

