Exemple de programme COBOL utilisant des API de sous-fichier

L'exemple suivant illustre comment les API de sous-fichier sont codées dans un programme source ILE COBOL.
PROCESS NOMONOPRC APOST.

IDENTIFICATION DIVISION.

PROGRAM-ID.        WDSCSRV.
  AUTHOR.          Nom du programmeur.
  INSTALLATION.    IBM Toronto Lab.
  DATE-WRITTEN.    15 juillet 2003.
  DATE-COMPILED.

*---------------------------------------------------------------------
* DESCRIPTION DU PROGRAMME
*
* Ce programme illustre l'appel de procédure destiné aux API de
* sous-fichier dans le programme de service QDTSSFL.
*
* Compile :
*   CRTCBLMOD MODULE(WDSCSRV)
*   CRTPGM PGM(WDSCSRV) BNDSRVPGM(QGPL/QDTSSFL)
*---------------------------------------------------------------------


ENVIRONMENT DIVISION.

CONFIGURATION SECTION.

  SOURCE-COMPUTER. IBM-I5/OS.
  OBJECT-COMPUTER. IBM-I5/OS.

INPUT-OUTPUT SECTION.

FILE-CONTROL.


DATA DIVISION.

FILE SECTION.

WORKING-STORAGE SECTION.

01 CUSTOMER-REC.
   05 CUSTOMER-NUMBER        PIC X(07).
   05 CUSTOMER-NAME          PIC X(40).
   05 REP-IDENTIFIER         PIC X(05).
   05 CUSTOMER-NAME          PIC X(30).
   05 CUSTOMER-PHONE-NUMBER  PIC X(17).
   05 CUSTOMER-FAX-NUMBER    PIC X(17).
   05 CUSTOMER-ADDRESS       PIC X(40).
   05 CUSTOMER-CITY          PIC X(30).
   05 CUSTOMER-COUNTRY       PIC X(20).
   05 CUSTOMER-POSTAL-CODE   PIC X(10).
   05 CUSTOMER-PC-LOCATION   PIC X(01).

01 MY-BUFFER                 PIC X(1000).
01 DUMMY                     PIC X(10).

*** Paramètres des API
01 SPACE-NAME-PTR                       USAGE POINTER.
01 RECORD-PTR                           USAGE POINTER.
01 DUMMY-PTR                            USAGE POINTER.
01 RECORD-LENGTH             PIC S9(09) USAGE BINARY.
01 RELATIVE-REC-NUMBER       PIC S9(09) USAGE BINARY.
01 RC                        PIC S9(09) USAGE BINARY.
01 RECORD-COUNT              PIC S9(09) USAGE BINARY.

LINKAGE SECTION.


PROCEDURE DIVISION.

0000-MAIN.

     SET SPACE-NAME-PTR TO ADDRESS OF MY-BUFFER.
     SET RECORD-PTR     TO ADDRESS OF CUSTOMER-REC.
     SET FILLER-PTR     TO ADDRESS OF DUMMY.
     MOVE 217           TO  RECORD-LENGTH.


*** API QdtsAppendSF - Ajout d'un enregistrement
     CALL PROCEDURE 'QdtsAppendSF' USING BY VALUE SPACE-NAME-PTR
                                                  RECORD-PTR
                                                  RECORD-LENGTH
                                   RETURNING RC.

*** API QdtsChainSF - Chaînage à un enregistrement
     CALL PROCEDURE 'QdtsChainSF' USING BY VALUE SPACE-NAME-PTR
                                                 RECORD-PTR
                                                 RECORD-LENGTH
                                              RELATIVE-REC-NUMBER
                                  RETURNING RC.

*** API QdtsClearSF - Effacement d'un sous-fichier
     CALL PROCEDURE 'QdtsClearSF' USING BY VALUE SPACE-NAME-PTR
                                  RETURNING RC.

*** API QdtsCountSF - Décompte des enregistrements de sous-fichier
     CALL PROCEDURE 'QdtsCountSF' USING BY VALUE SPACE-NAME-PTR
                                  RETURNING RECORD-COUNT.

*** API QdtsDeleteSF - Suppression d'un enregistrement de sous-fichier
     CALL PROCEDURE 'QdtsDeleteSF' USING BY VALUE SPACE-NAME-PTR
                                               RELATIVE-REC-NUMBER
                                   RETURNING RC.

*** API QdtsInitSF - Initialisation du sous-fichier
     CALL PROCEDURE 'QdtsInitSF' USING BY VALUE SPACE-NAME-PTR
                                                DUMMY-PTR
                                                RECORD-LENGTH
                                 RETURNING RC.

*** API QdtsReadcSF - Lecture d'un enregistrement
     CALL PROCEDURE 'QdtsReadcSF' USING BY VALUE SPACE-NAME-PTR
                                                 RECORD-PTR
                                                 RECORD-LENGTH
                                               RELATIVE-REC-NUMBER
                                  RETURNING RC.

*** API QdtsUpdateSF - Mise à jour d'un enregistrement
     CALL PROCEDURE 'QdtsUpdateSF' USING BY VALUE SPACE-NAME-PTR
                                                  RECORD-PTR
                                                  RECORD-LENGTH
                                               RELATIVE-REC-NUMBER
                                   RETURNING RC.

     STOP RUN.

Commentaires en retour