Quelle objserv.cob Sprache: Cobol

      *******************************************
      *
      * MODULE NAME      OBJSERV.COB
      *
      * DESCRIPTIVE NAME CICS for MVS/ESA CWI Graphics Server Sample Program
      *
      * Statement:       Licensed Materials - Property of IBM
      *
      *                  CA84 SupportPac
      *                  (c) Copyright IBM Corp. 1997
      *
      *                  All rights reserved.
      *
      *                  U.S. Government Users Restricted Rights - use,
      *                  duplication or disclosure restricted by GSA
      *                  ADP Schedule Contract with IBM Corp.
      *
      * Status:          Version 1 Release 0 Modification 1
      * Last Modified    10 October 1997
      *                  Modified template manager comm-area creation step
      *                  to set address of returned data
      * Author:          Steve Wall
      *
      *  NOTES :-
      *   DEPENDENCIES   CICS for MVS/ESA V4.1
      *                  Internet Connection Server for MVS/ESA
      *
      * This program is a cobol CWI converter program which implements
      * one method of delivering graphics through the CWI.
      * It will serve graphics from a URL
      * of the form http://your.cics.system/objserv/graphic.gif .
      *
      *******************************************

      *******************************************
      *
      * PROGRAM NAME: OBJSERV
      *
      * TITLE: Cobol Sample CWI Graphics Server Converter Program.
      *
      * PROGRAM DESCRIPTION:
      *
      * This program will show an example of how to code a converter
      * to send binary objects up to 32K in length over the web.
      *
      * SYSTEM LEVEL:  CICS 4.1 or higher.
      *
      * INPUT:
      *
      * The target file is passed in the URL.
      *
      * OUTPUT:
      *
      * The target file is returned to the browser. If an error occurs
      * then a 404 is returned.
      *
      *****************************************

       PROCESS XOPTS(NOLINKAGE)
       IDENTIFICATION DIVISION.
       PROGRAM-ID. OBJSERV.
       ENVIRONMENT DIVISION.
       DATA DIVISION.
       WORKING-STORAGE SECTION.
       COPY DFHWBUCO.

      ******
      *  Data items.
      ******
      *  Simple data types used for interaction with CICS.
      ******

       77 conv-pointer       POINTER.
       77 init-val           PIC X VALUE LOW-VALUES.

       77 resp               PIC S9(4).
       77 resp2              PIC S9(4).

      ******
      *  Specific stuff for the decode function.
      ******

       77 file-name          PIC X(8).
       77 counter            PIC S9(4) COMP.
       77 url-character-ptr  POINTER.

      ******
      *  Http header stuff.
      ******

       01 mime-type.
          05 filler          PIC X(6) VALUE IS 'image/'.
          05 extension       PIC X(4) VALUE IS '****'.

       01 header.
          05 filler          PIC X(23) VALUE IS
                                 'HTTP/1.0 200 Image file'.
          05 filler          PIC X(2)  VALUE IS x'0D25'.
          05 filler          PIC X(16) VALUE IS 'Content-Length: '.
          05 clen            PIC 9(5).
          05 filler          PIC X(2)  VALUE IS x'0D25'.
          05 filler          PIC X(14) VALUE IS 'Content-Type: '.
          05 type-of-data    PIC X(10) VALUE IS '**********'.
          05 filler          PIC X(2)  VALUE IS x'0D25'.
          05 filler          PIC X(2)  VALUE IS x'0D25'.

       01 failure-header.
          05 filler         PIC X(13) VALUE IS 'HTTP/1.0 404 '.
          05 filler         PIC X(14) VALUE IS 'File not found'.
          05 filler         PIC X(2)  VALUE IS x'0D25'.
          05 filler         PIC X(2)  VALUE IS x'0D25'.

      ******
      *  Data constants.
      ******

       01 lower  PIC X(26) VALUE 'abcdefghijklmnopqrstuvwxyz'.
       01 filler REDEFINES lower.
          05  lowerc PIC X OCCURS 26 INDEXED BY lowerc-idx.
       01 upper  PIC X(26) VALUE 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'.
       01 filler REDEFINES upper.
          05  upperc PIC X OCCURS 26.

       COPY DFHWBTLO.

      ******
      *  Now for the overlay structures.
      ******

       LINKAGE SECTION.

       COPY DFHEIBLC.
       COPY DFHWBCDO.

       01 returned-data.
          05 http-len            PIC 9(8) COMP.
          05 header1             PIC X(76).
          05 the-binary-data     PIC X(32683).

       77 the-url                PIC X(1000).
       77 url-character          PIC X.

       PROCEDURE DIVISION USING DFHEIBLK DFHCOMMAREA.

      ******
      *  First part: set up the pointers and structures, perform
      *  sanity checks and the call the decode/encode functions.
      ******
      *  Just return if no commarea because there's nowhere to work.
      ******

           IF EIBCALEN = 0
              EXEC CICS RETURN END-EXEC
           END-IF

      ******
      *  Set up addressability to the commarea.
      ******

           EXEC CICS
                ADDRESS COMMAREA(conv-pointer)
           END-EXEC.

           SET ADDRESS OF CONVERTER-PARMS TO conv-pointer.

      ******
      *  Validate the commarea eyecatcher.
      ******

           IF (CONVERTER-EYECATCHER NOT = DECODE-EYECATCHER-INIT)
           AND (CONVERTER-EYECATCHER NOT = ENCODE-EYECATCHER-INIT)
               MOVE URP-INVALID TO CONVERTER-RESPONSE
               MOVE URP-CORRUPT-CLIENT-DATA TO CONVERTER-REASON

               EXEC CICS
                    RETURN
               END-EXEC
           END-IF

           IF CONVERTER-RESPONSE NOT = 0
               EXEC CICS
                    RETURN
               END-EXEC
           END-IF

           IF CONVERTER-REASON NOT = 0
               EXEC CICS
                    RETURN
               END-EXEC
           END-IF

           EVALUATE CONVERTER-FUNCTION

      ******
      *  If decode is set then do all the interesting stuff.
      ******

           WHEN URP-DECODE
               PERFORM DECODE

      ******
      *  If encode is set then return. (Encode is a null function)
      ******

           WHEN URP-ENCODE
               MOVE URP-OK TO CONVERTER-RESPONSE

      ******
      *  otherwise there is a problem
      ******

           WHEN OTHER
               MOVE URP-DISASTER TO CONVERTER-RESPONSE
               MOVE URP-CORRUPT-CLIENT-DATA TO CONVERTER-REASON
               EXEC CICS
                    RETURN
               END-EXEC
           END-EVALUATE

      ******
      *  Now we return.
      ******

           EXEC CICS
                RETURN
           END-EXEC.

       A999-EXIT.
           EXIT.

      ********************
       BB-DECODE SECTION.
      ********************

       DECODE.
      ***************

      ******
      *  First we need to find the file name.
      ******
      *  Set up pointers to the url.
      ******

           MOVE DECODE-RESOURCE-LENGTH TO counter

           SET ADDRESS OF the-url TO DECODE-RESOURCE-PTR
           SET ADDRESS OF url-character TO
               ADDRESS OF the-url(counter : 1)

      ******
      *  Find the last '/' in the url.
      ******

           PERFORM WITH TEST BEFORE UNTIL url-character = '/'
               COMPUTE counter = counter - 1
               SET ADDRESS OF url-character TO
                   ADDRESS OF the-url(counter : 1)
           END-PERFORM

           COMPUTE counter = counter + 1

           SET ADDRESS OF the-url TO ADDRESS OF the-url(counter : 1)

      ******
      *  Save the filename and extension + convert to upper case.
      ******

           UNSTRING the-url
                DELIMITED BY ';' OR '?' OR '.' OR ' '
                INTO file-name extension

           PERFORM WITH TEST AFTER VARYING counter FROM 1 BY +1
               UNTIL counter = 26
               INSPECT file-name REPLACING ALL
                   lowerc(counter) BY upperc(counter)
               INSPECT extension REPLACING ALL
                   lowerc(counter) BY upperc(counter)
           END-PERFORM

      ******
      *  Create the mime type and embed it in the http header
      *  assume a default of 'gif' if the extension isn't recognised.
      ******

           EVALUATE extension(1:3)
               WHEN 'JPE'
                   MOVE 'jpeg' TO extension
               WHEN 'JPG'
                   MOVE 'jpeg' TO extension
               WHEN OTHER
                   MOVE 'gif'  TO extension
           END-EVALUATE

           MOVE mime-type TO type-of-data

      ******
      *  Having found the filename we need to recover the file.
      ******
      *  Create the template manager comm-area.
      ******

           SET ADDRESS OF returned-data TO DECODE-DATA-PTR

           MOVE LOW-VALUES TO DFHWBTL-ARG

      ******
      *  Set up and run the template manager. We are using it simply
      *  to copy the binary image data to the data buffer, no
      *  symbol replacements are required.
      ******

           MOVE 0                         TO WBTL-VERSION-NO
           MOVE WBTL-BUILD-HTML-PAGE      TO WBTL-FUNCTION
           MOVE file-name                 TO WBTL-TEMPLATE-NAME
           SET  WBTL-HTML-BUFFER-PTR      TO ADDRESS OF the-binary-data
           MOVE LENGTH OF the-binary-data TO WBTL-HTML-BUFFER-LEN

           EXEC CICS
                LINK PROGRAM('DFHWBTL')
                COMMAREA(DFHWBTL-ARG)
                LENGTH(56)
                RESP(resp) RESP2(resp2)
           END-EXEC

      ******
      *  If theres an error then handle it.
      ******

           IF resp NOT = WBTL-OK
                PERFORM CREATE-ERROR-RESPONSE
           END-IF

      ******
      *  Now the binary data is in place we set up the length
      *  fields and add the header.
      ******
      *  Calculate the length of the http response. An extra 2
      *  bytes are deducted to nullify the CRLF character pair
      *  that the template manager automatically adds to the end
      *  of the data.
      ******

           COMPUTE http-len = (LENGTH OF returned-data -
                               WBTL-HTML-BUFFER-LEN) - 2

           COMPUTE clen     = (LENGTH OF the-binary-data -
                               WBTL-HTML-BUFFER-LEN) - 2

      ******
      *  And finaly add the header that we've been building up.
      ******

           MOVE header TO header1.

       BB999-EXIT.
           EXIT.

      ******************
       C-ERROR SECTION.
      ******************

       CREATE-ERROR-RESPONSE.
      ************************

      ******
      *  If any error is detected return a 404 to the browser.
      ******

           COMPUTE http-len = LENGTH OF failure-header + 4
           MOVE failure-header TO header1

           EXEC CICS
                RETURN
           END-EXEC.

      ******
      *  And that's it.
      ******

       CC999-EXIT.
           EXIT.

quality99%

¤ Dauer der Verarbeitung: 0.8 Sekunden ¤

Wurzel

Suchen

Beweissystem der NASA

Beweissystem Isabelle

NIST Cobol Testsuite

Cephes Mathematical Library

Wiener Entwicklungsmethode

Haftungshinweis

Die Informationen auf dieser Webseite wurden nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit, noch Qualität der bereit gestellten Informationen zugesichert.

Bemerkung:

Die farbliche Syntaxdarstellung ist noch experimentell.