Pause-Café Volubis

pause-café

rendez-vous technique
Pause-Café est une réunion technique
destinée aux informaticiens sur plateforme IBM i.
Elle a lieu 3 à 4 fois par an : en Bretagne et sur internet.

Pause-café #15

Juin 1998

Fin


    API Messages (permettent de traiter les messages en pgm HLL).


     Exemple :            Déplacement de messages vers une autre PGMQ
                           (dans la liste d'invocation)
                          ATTENTION: Les messages *ESCAPE deviennent *DIAG


                          + QMHMOVPM


                          - BIN(4)   clé du message (blanc = tous)
                          - x fois CHAR(10) = type(s) de messages
                                              *COMP,*DIAG,*ESCAPE,*INFO
                                              0 = par clé
                                              1 à 4 si clé = blanc
                          - BIN(4)   nombre de types (0 à 4)
                          - CHAR(10) PGMQ contenant les messages
                                     - un nom de pgm
                                     - '*' = le pgm en cours.
                          - BIN(4)   n° dans la pile  0 = le pgm en cours
                                                      1 = l'appelant
                                                      x = x niveau au dessus
                          - CHAR(?)  Zone de retour d'erreur


    API Messages




     + QMHRCVM            Réception de messages à partir d'une MSGQ
                           (RCVMSG MSGQ(xxx).)




     + QMHRCVPM          Réception de messages à partir d'une PGMQ
                           (RCVMSG PGMQ(xxx).)




     + QMHRMVM            suppression de message(s) d'une MSGQ
                           (RMVMSG)




     + QMHRMVPM           suppression de message(s) d'une PGMQ
                           (RMVMSG)







              

     + QMHRSNEM           Renvoi le dernier message *ESCAPE reçu par un pgm
                           vers l'appelant, toujours de type *ESCAPE.




     + QMHRTVM           Retrouve la définition d'un message.
                           (RTVMSG)




     + QMHRTVRQ           Réception de messages *RQS    PRATIQUE POUR 
                           (RCVMSG PGMQ(*EXT).)          GERER F9 sur une
                                                         ligne de cde.


     + QMHSNDBM          envoi un message en  BREAK
                           (SNDBRKMSG)




     + QMHSNDM           envoi un message à une MSGQ
                           (SNDPGMMSG TOMSGQ(xxx).)




     + QMHSNDPM          envoi un message à une PGMQ
                           (SNDPGMMSG TOPGMQ(xxx).)


Quelques exemples d'utilisation en RPG:


      * déclarations communes


     E                    MTYP        2 10
     IMSGTB       DS
     I                                        1  20 MTYP
     IMSGDS       DS
     I                                        1  10 MSGF
     I                                       11  20 MSGL
     I                                        1  20 MSGFL
     I                                    B  21  240LENTXT
     I                                    B  25  280STACK
     I                                    B  29  320KEY
     I                                    B  33  360NBTYP
     ICODERR      DS
     I I            16                    B   1   40LGCOD
     I                                    B   5   80LGUTIL
     I                                        9  15 MSGID
     I                                       16  16 RESERV

              


      * gestion des erreurs en cas de probleme
         ...............
      *
      * EN CAS D'ERREUR ==> RENVOI DES MESSAGES ET CANCEL DU PGM
      *
     C           *PSSR     BEGSR
     C                     MOVEL'*DIAG'   MTYP,1
     C                     MOVEL'*ESCAPE' MTYP,2
     C                     CALL 'QMHMOVPM'
     C                     PARM           MSGCLE  4
     C                     PARM           MSGTB
     C                     PARM 2         NBTYP
     C                     PARM '*'       PGMQ   10
     C                     PARM 1         STACK
     C                     PARM           CODERR
     C                     ENDSR'*CANCL'









              


      * envoi de message *STATUS dans l'external


     I              'Liste en cours..'    C         MTX
     I              'Liste terminée  '    C         MTX2
     C                     MOVEL'QCPFMSG' MSGF
     C                     MOVEL'*LIBL'   MSGL
     C                     MOVELMTX       MSGTXT


     C                     CALL 'QMHSNDPM'
     C                     PARM 'CPF9898' ID      7
     C                     PARM           MSGFL
     C                     PARM           MSGTXT 50
     C                     PARM 50        LENTXT
     C                     PARM '*STATUS' MSGTYP 10
     C                     PARM '*EXT'    PGMQ   10
     C                     PARM 0         STACK
     C                     PARM           KEY
     C                     PARM           CODERR
      * sous programme de chargement
     C                     EXSR ----
      *

     C                     MOVELMTX2      MSGTXT
     C                     CALL 'QMHSNDPM'
     C                     PARM 'CPF9898' ID      7
     C                     PARM           MSGFL
     C                     PARM           MSGTXT 50
     C                     PARM 50        LENTXT
     C                     PARM '*STATUS' MSGTYP 10
     C                     PARM '*EXT'    PGMQ   10
     C                     PARM 0         STACK
     C                     PARM           KEY
     C                     PARM           CODERR


       * supprime tous les messages reçus entre deux affichages
       * (DSPF avec sous-fichier message)
     C                     CALL 'QMHRMVPM'
     C                     PARM '*'       PGMQ   10
     C                     PARM 0         STACK
     C                     PARM           KEY
     C                     PARM '*ALL'    RMVOPT 10
     C                     PARM           CODERR



              

       *
       * exemple en RPG-IV, retrouve le nom du pgm appellant
       *


     Dbinaire          S             10I 0


     DLENTXT           S                   like(binaire)
     DSTACK            S                   like(binaire)
     DKEY              S                   like(binaire)
     DATTENTE          S                   like(binaire)


     DCODERR           DS
     D  LGCOD                              like(binaire)   INZ(16)
     D  LGUTIL                             like(binaire)
     D  MSGID                         7
     D  RESERV                        1


      *
      *  on envoi un message au programme au-dessus (stack = 1)
      *  et on le relit (dans les infos retournées il y a le nom du pgm)
      *

              

     C                   CALL      'QMHSNDPM'
     C                   PARM                    ID                7
     C                   PARM                    MSGFL            20
     C                   PARM      'peu importe' MSGTXT           10
     C                   PARM      10            LENTXT
     C                   PARM      '*INFO  '     MSGTYP           10
     C                   PARM      '*'           PGMQ             10
     C                   PARM      1             STACK
     C                   PARM                    KEY
     C                   PARM                    CODERR
     C                   CALL      'QMHRCVPM'
     C                   PARM                    retour          120
     C                   PARM      120           lentxt
     C                   PARM      'RCVM0200'    format            8
     C                   PARM      '*'           PGMQ             10
     C                   PARM      1             STACK
     C                   PARM      '*ANY'        MSGTYP
     C                   PARM                    KEY
     C                   PARM      0             ATTENTE
     C                   PARM      '*REMOVE'     ACTION           10
     C                   PARM                    CODERR
     c                   eval      pgm = %subst(retour:111:10)

       *
       * le même exemple en RPG-IV, sous forme d'une fonction
       *
       *         utilisable sous la forme  if quiappel(1) = 'xxxx' 


     H  nomain


      * prototype de la fonction
      *
      *  (tout programme utilisant la fonction doit lui-même
      *    contenir les deux lignes qui suivent)


     Dquiappel         PR            10
     D                               10I 0


      * corps de la fonction
     Pquiappel         B
     D                 PI            10
     D  niveau                       10I 0


      *  variables locales
     Dbinaire          S             10I 0


     DLENTXT           S                   like(binaire)
     DSTACK            S                   like(binaire)
     DKEY              S                   like(binaire)
     DATTENTE          S                   like(binaire)


     DCODERR           DS
     D  LGCOD                              like(binaire)   INZ(16)
     D  LGUTIL                             like(binaire)
     D  MSGID                         7
     D  RESERV                        1


      *
      *  on envoi un message au programme au-dessus
      *  et on le relit (dans les infos retournées il y a le nom du pgm)
      *


      * on rajoute UN pour tenir compte de la place occupée par le pgm
      * utilisant lui même la fonction et de laplace du PEP (entry point)
     c                   eval      stack = niveau + 2


     C                   CALL      'QMHSNDPM'

     C                   PARM                    ID                7
     C                   PARM                    MSGFL            20
     C                   PARM      'peu importe' MSGTXT           10
     C                   PARM      10            LENTXT
     C                   PARM      '*INFO  '     MSGTYP           10
     C                   PARM      '*'           PGMQ             10
     C                   PARM                    STACK
     C                   PARM                    KEY
     C                   PARM                    CODERR
     C                   CALL      'QMHRCVPM'
     C                   PARM                    retour          120
     C                   PARM      120           lentxt
     C                   PARM      'RCVM0200'    format            8
     C                   PARM      '*'           PGMQ             10
     C                   PARM                    STACK
     C                   PARM      '*ANY'        MSGTYP
     C                   PARM                    KEY
     C                   PARM      0             ATTENTE
     C                   PARM      '*REMOVE'     ACTION           10
     C                   PARM                    CODERR
     c                   return    %subst(retour:111:10)
     Pquiappel         E

  Registration Facility 


 Nouvelles fonction de l'OS permettant d'associer à une fonction logiciel
  un pgm de contrôle entreprise chargé de valider une action.


 DEUX NOTIONS :


    - Exit POINT : association d'un point d'appel de programme à une
                    action logiciel.


                   ce point d'appel est nommé sur 20 caractères.


      Exemple : QIBM_QPWSF_File_Serveur la fonction serveur de fichier
                  de Client/Access est reconnue, il est possible de lui
                  associer un pgm de validation.


     > APIs : QUSRGPT permet de définir un point d'exit.
              + paramètres : nom du point d'exit, modifiable ou non
                             action et format des données transmises au pgm
                             nombre de programes d'exit maxi                  # 
                             possibilité d'enlever ce point d'exit ou non.
              QUSDRGPT permet d'enlever ce point d'exit.

  Registration Facility 


 Nouvelles fonction de l'OS permettant d'associer à une action logiciel
  un pgm de contrôle entreprise chargé de valider cette action.


 DEUX NOTIONS :


    - Exit program : programme associé à un point d'exit.
                       l'écriture est à votre charge


           il reçoit deux paramètres
              1/ 1 alpha renvoyé par le programme '0' = refus
                                                  '1' = validation
              2/ données reçues (description suivant le format)


     > APIs : QUSADDEP ajout d'un programe d'exit
              QUSRMVEP retrait un programe d'exit
              QUSRTVEI extraction d'informations


     > Commandes : WRKREGINF                                                  # 
                   ADDEXITPGM
                   RMVEXITPGM

                              Attributs du réseau 
                                                            Système:   S4409790 
 Nombre maximal d'étapes  . . . . . . . . . . . . :   16  
 Accès aux demandes DDM . . . . . . . . . . . . . :   *OBJAUT    
 Accès aux demandes Client Access . . . . . . . . :   *REGFAC  <--
 Type du réseau RNIS par défaut . . . . . . . . . :                
 Liste de connexion RNIS par défaut . . . . . . . :   QDCCNNLANY 
 Support ANYNET admis . . . . . . . . . . . . . . :   *NO  
 Domaine du serveur de réseau . . . . . . . . . . :   S4409790 


 ######################################################################## 
 #                                                                      #   
 #  Pour utiliser ces concepts avec Client/Access vous devez saisir :   #  
 #       CHGNETA PCSACC(*REGFAC)                                        #   
 #                                                                      # 
 #  ce qui permet d'avoir un pgm de contrôle par fonction               #   
 #   (et non un pgm général comme en V2R30)                             # 
 #                                                                      # 
 ########################################################################   Fin 
 Appuyez sur ENTREE pour continuer. 


 F3=Exit   F12=Annuler 

                     Work with Registration Info (WRKREGINF)   


 Indiquez vos choix, puis appuyez sur ENTREE. 


 Exit point . . . . . . . . . . . EXITPNT        *REGISTERED               
 Exit point format  . . . . . . . FORMAT         *ALL     
 Output . . . . . . . . . . . . . OUTPUT         *      






 ######################################################################### 
 #                                                                       # 
 # Puis utilisez WRKREGINF qui affiche tous les points d'exit définis.   # 
 #                                                                       # 
 ######################################################################### 








                                                                            Fin 
 F3=Exit   F4=Invite   F5=Réafficher   F12=Annuler   F13=Mode d'emploi invite
 F24=Autres touches                                                             


 voici la liste des points d'exit définis en V4R20 :




 Exit
 Point                 Format     Text
---------------------------------------------------------------------------
 QIBM_QHQ_DTAQ         DTAQ0100   Original Data Queue Server
 QIBM_QJO_DLT_JRNRCV   DRCV0100   Delete Journal Receiver
 QIBM_QLZP_LICENSE     LICM0100   Original License Mgmt Server
 QIBM_QMF_MESSAGE      MESS0100   Original Message Server
 QIBM_QNPS_ENTRY       ENTR0100   Network Print Server - entry
 QIBM_QNPS_SPLF        SPLF0100   Network Print Server - spool
 QIBM_QOE_OV_USR_ADM   UADM0100   OfficeVision/400 Administration
 QIBM_QOE_OV_USR_SND   DOCI0900   OfficeVision/400 Mail Send Exit point
 QIBM_QOK_NOTIFY       VRFY0100   System Directory Notify Exit point
 QIBM_QOK_SUPPLIER     SUPL0100   System Directory Supplier Exit point
 QIBM_QOK_VERIFY       VRFY0100   System Directory Verify Exit point
 QIBM_QPWFS_FILE_SERV  PWFS0100   File Server
 QIBM_QRQ_SQL          RSQL0100   Original Remote SQL Server
 QIBM_QSU_LCMD         EXTP0100   EXIT POINT FOR SEU USER DEFINE COMMANDS

              


 QIBM_QSY_CHG_PROFILE  CHGP0100   Change User Profile
 QIBM_QSY_CRT_PROFILE  CRTP0100   Create User Profile
 QIBM_QSY_DLT_PROFILE  DLTP0100   Delete User Profile - after delete
 QIBM_QSY_DLT_PROFILE  DLTP0200   Delete User Profile - before delete
 QIBM_QSY_RST_PROFILE  RSTP0100   Restore User Profile
 QIBM_QTA_STOR_EX400   EX400200   Storage Extension Exit Program
 QIBM_QTA_TAPE_TMS     TMS00200   Tape Management Exit Program
 QIBM_QTF_TRANSFER     TRAN0100   Original File Transfer Function
 QIBM_QTG_DEVINIT      INIT0100   Telnet Device Initialization
 QIBM_QTG_DEVTERM      TERM0100   Telnet Device Termination
 QIBM_QTMF_CLIENT_REQ  VLRQ0100   FTP Client Request Validation
 QIBM_QTMF_SERVER_REQ  VLRQ0100   FTP Server Request Validation
 QIBM_QTMF_SVR_LOGON   TCPL0100   FTP Server Logon
 QIBM_QTMT_WSG         QAPP0100   WSG Server Sign-On Validation
 QIBM_QTMX_SERVER_REQ  VLRQ0100   REXEC Server Request Validation
 QIBM_QTMX_SVR_LOGON   TCPL0100   REXEC Server Logon
 QIBM_QTOD_DHCP_ABND   DHCA0100   DHCP Address Binding Notify
 QIBM_QTOD_DHCP_ARLS   DHCR0100   DHCP Address Release Notify
 QIBM_QTOD_DHCP_REQ    DHCV0100   DHCP Request Packet Validation
 QIBM_QTOD_SERVER_REQ  VLRQ0100   TFTP Server Request Validation

              


 QIBM_QVP_PRINTERS     PRNT0100   Original Virtual Print Server
 QIBM_QWC_PWRDWNSYS    PWRD0100   Prepower down system exit point
 QIBM_QWC_QSTGLOWACN   STGL0100   Auxiliary storage lower limit
 QIBM_QWT_JOBNOTIFY    NTFY0100   JOB NOTIFICATION
 QIBM_QWT_PREATTNPGMS  ATTN0100   Preattention program exit point
 QIBM_QWT_SYSREQPGMS   SREQ0100   Presystem request pgm exit point
 QIBM_QZCA_ADDC        ZCAA0100   Add Client exit point
 QIBM_QZCA_REFC        ZCAF0100   Refresh Client Information exit point
 QIBM_QZCA_RMVC        ZCAR0100   Remove Client exit point
 QIBM_QZCA_SNMPTRAP    ZCAT0100   SNMP trap routing exit point
 QIBM_QZCA_UPDC        ZCAU0100   Update Client Information exi
 QIBM_QZDA_INIT        ZDAI0100   Database Server - entry
 QIBM_QZDA_NDB1        ZDAD0100   Database Server - data base access
 QIBM_QZDA_NDB1        ZDAD0200   Database Server - data base access
 QIBM_QZDA_ROI1        ZDAR0100   Database Server - object information
 QIBM_QZDA_ROI1        ZDAR0200   Database Server - object information
 QIBM_QZDA_SQL1        ZDAQ0100   Database Server - SQL access
 QIBM_QZDA_SQL2        ZDAQ0200   Database Server - SQL access
 QIBM_QZHQ_DATA_QUEUE  ZHQ00100   Data Queue Server



              


 QIBM_QZMFMSF_ACT      MSFF0100   MSF Accounting Exit
 QIBM_QZMFMSF_ADR_RSL  MSFF0100   MSF Address Resolution
 QIBM_QZMFMSF_ATT_CNV  MSFF0100   MSF Attachment Conversion
 QIBM_QZMFMSF_ATT_MGT  MSFF0100   MSF Attachment Management
 QIBM_QZMFMSF_ENL_PSS  MSFF0100   MSF Envelope Processing
 QIBM_QZMFMSF_LCL_DEL  MSFF0100   MSF Local Delivery
 QIBM_QZMFMSF_LST_EXP  MSFF0100   MSF List Expansion
 QIBM_QZMFMSF_MSG_FWD  MSFF0100   MSF Message Forwarding
 QIBM_QZMFMSF_NON_DEL  MSFF0100   MSF Non Delivery
 QIBM_QZMFMSF_SEC_AUT  MSFF0100   MSF Security and Authority
 QIBM_QZMFMSF_TRK_CHG  MSFF0100   MSF Track Mail Message Change
 QIBM_QZMFMSF_VLD_TYP  MSFF0100   MSF Validate Type
 QIBM_QZRC_RMT         CZRC0100   Remote Command/Program Call
 QIBM_QZSC_LM          ZSCL0100   Central Server - license mgmt
 QIBM_QZSC_NLS         ZSCN0100   Central Server - conversion map
 QIBM_QZSC_SM          ZSCS0100   Central Server - client mgmt
 QIBM_QZSO_SIGNONSRV   ZSOY0100   TCP Signon Server




  comment associer un programme :

              

                       Work with Registration Information 


 Type options, press Enter. 
   5=Display exit point   8=Work with exit programs   <-- 


                            Exit 
      Exit                  Point 
 Opt  Point                 Format    Registered  Text 
      QIBM_QHQ_DTAQ         DTAQ0100     *YES     Original Data Queue Server    
      QIBM_QLZP_LICENSE     LICM0100     *YES     Original License Mgmt Server  
      QIBM_QMF_MESSAGE      MESS0100     *YES     Original Message Server       
      QIBM_QNPS_ENTRY       ENTR0100     *YES     Network Print Server - entry  
      QIBM_QNPS_SPLF        SPLF0100     *YES     Network Print Server - spool  
      QIBM_QOE_OV_USR_ADM   UADM0100     *YES     OfficeVision/400 Administrati 
      QIBM_QOK_SUPPLIER     SUPL0100     *YES     System Directory Supplier Exi 
      QIBM_QOK_VERIFY       VRFY0100     *YES     System Directory Verify Exit  
  8   QIBM_QPWFS_FILE_SERV  PWFS0100     *YES     File Server                   
      QIBM_QRQ_SQL          RSQL0100     *YES     Original Remote SQL Server    
                                                                    A suivre... 
 Command 
 ===>                                                                           
 F3=Exit   F4=Prompt   F9=Retrieve   F12=Cancel 

                            Work with Exit Programs 


 Exit point:   QIBM_QPWFS_FILE_SERV     Format:   PWFS0100 


 Type options, press Enter. 
   1=Add   4=Remove   5=Display   10=Replace 


               Exit 
             Program     Exit 
 Opt          Number     Program        Library 
 1                                                 


   (No exit programs found.)                                                    
 #################################################################### 
 #                                                                  #  
 # Sur cet écran 1 = ADDEXITPGM : ajout d'un pgm d'exit             #  
 #               4 = RMVEXITPGM : retrait d'un pgm d'exit           # 
 #                                                                  # 
 ####################################################################  Fin 
 Command 
 ===>                                                                      
 F3=Exit   F4=Prompt   F5=Refresh   F9=Retrieve   F12=Cancel 


 Quelques précisions :


  un point d'exit peut avoir plusieurs "formats".


     il s'agit de la définition de plusieurs actions pouvant être réalisées
      par la même fonction.


      exemple du point d'exit QIBM_QZDA_NDB1 serveur de données (ODBC) :


      format ZDAD0100 = gestion de la base (CREATE, DROP, etc...)
             ZDAD0200 = Gestion de la liste de bibliothèques (ADDLIBLE)


     chaque format définit la structure des données envoyées au pgm.


     pour connaitre le détail d'un format voir la documentation


     SC41-374 : "OS/400 server concept and administration "




  Ci-dessous, les plus importants :

              

 QIBM_QPWSF_FIle_Serveur : serveur de fichier V3R10


 Format PWFS0100 :   - CHAR(10)   Profil utilisateur


                     - CHAR(10)   fonction = '*FILESRV'


                     - BIN(4) Action : 1 = modif des attributs
                                       2 = création (STMF ou directory)
                                       3 = supression ( "       "     )
                                       4 = liste des attributs
                                       5 = MOV
                                       6 = OPEN
                                       7 = RNM
                                       8 = Allocate d'une conversation


                     - CHAR(8) format = 'PWFS0100'


                     - CHAR(4)  type d'ouverture (1=oui, 0=non)
                                         - CHAR(1) Read
                                         - CHAR(1) write
                                         - CHAR(1) Read/write
                                         - CHAR(1) delete possible


                     - BIN(4)  lg du nom de fichier


                     - CHAR(??) nom du fichier


                       y compris le chemin, lg maxi 16Mo.


  ATTENTION : le nom du fichier est donné en UNICODE.


 Il s'agit d'une norme de codification ISO (basée sur l'ASCII) qui tient
  compte des paramètres nationaux :


  - codée sur deux octets pour les idéogrammes asiatiques (DBCS)


    en france le premier octet vaut TOUJOURS x'00'


  - tenant compte du code page et des caractères accentués (comme l'ANSI)


 Voir l'exemple ci-dessous qui propose une conversion EBCDIC/UNICODE pour
  les chiffres et les caractères sans accents (partie invariante du LATIN 1)



              


             PGM        PARM(&VALID &PARAM)
             DCL        VAR(&VALID) TYPE(*CHAR) LEN(1)
             DCL        VAR(&PARAM) TYPE(*CHAR) LEN(512)
             DCL        VAR(&LGPATH) TYPE(*DEC) LEN(9 0)
             DCL        VAR(&UNICODE) TYPE(*CHAR) LEN(128)
             DCL        VAR(&PATH) TYPE(*CHAR) LEN(64)


/*********************************************************************/
/*QIBM_QPWSF_FIle_Serveur : serveur de fichier V3R10                 */
/*                                                                   */
/*Format PWFS0100 :  - CHAR(10)   Profil utilisateur                */
/*                   - CHAR(10)   fonction = '*FILESRV'              */
/*                   - BIN(4) Action : 1 = modif des attributs       */
/*                                     2 = création (STMF ou director*/
/*                                     3 = supression ( "       "    */
/*                                     4 = liste des attributs       */
/*                                     5 = MOV                       */
/*                                     6 = OPEN                      */
/*                                     7 = RNM                       */
/*                                     8 = Allocate d'une conversatio*/
/*                                                                   */

/*                   - CHAR(8) format = 'PWFS0100'                   */
/*                   - CHAR(4)  type d'ouverture (1=oui, 0=non)      */
/*                                       - CHAR(1) Read              */
/*                                       - CHAR(1) write             */
/*                                       - CHAR(1) Read/write        */
/*                                       - CHAR(1) delete possible   */
/*   37 A 40         - BIN(4)  lg du nom de fichier                  */
/*   41 A --         - CHAR(??) nom du fichier                       */
/*                                                                   */
/*********************************************************************/
/* EXTRACTION DES PARAMETRES                                         */
             CHGVAR     VAR(&LGPATH) VALUE(%BIN(&PARAM 37 4))
             IF         COND(&LGPATH > 128) THEN(CHGVAR VAR(&LGPATH) +
                          VALUE(128))
             CHGVAR     VAR(&UNICODE) VALUE(%SST(&PARAM 41 &LGPATH))
/* CVT UNICODE -> EBCDIC                                             */
             CALL UNICODE PARM(&UNICODE 128 &PATH)
/* REFUS SI CHEMIN COMMENCE PAR QSYS.LIB                             */
             IF (%SST(&PATH 1 9) = '/QSYS.LIB') CHGVAR &VALID '0'
/* SINON OK                                                          */
             ELSE CHGVAR &VALID '1'
             ENDPGM


 puis le PRG associé :




     ***********************************************************************
     **                                                                   **
     ** Ce pgm convertit des données UNICODE en EBCDIC.                   **
     **                                                                   **
     **  le premier paramètre contient la chaîne de caractères en UNICODE **
     **   - chaque caractère est codé sur 2 octets (pour DBCS)            **
     **     1er  octet x'00'                                              **
     **     2ème octet le caractère en ASCII                              **
     **   - le deuxième paramètre donne la longueur du premier            **
     **   - le troisième paramètre est la variable qui contiendra         **
     **        le code EBCDIC (elle doit être de 2 fois plus petite)      **
     **                                                                   **
     **   ATTENTION                                                       **
     **                                                                   **
     **      ce programme ne tient pas compte des paramètres nationaux    **
     **       (caractères accentués), il n'est donc fiables que pour      **
     **       la partie invariante des codes page                         **
     ***********************************************************************

     Dinput            s           2048
     Doutput           s           1024
     Dunids            ds
     Dunicod                       2048
     Dunitab                          1    dim(2048) overlay(unicod)
     Debcds            ds
     Debcdic                       1024
     Debctab                          1    dim(1024) overlay(ebcdic)
     Dinl              s             15  5
     Dinl2             s              5  0
     Doutl             s              5  0
     Di                s              5  0
     Dqebcdic          s             10    inz('QEBCDIC')
     Dqebcdiclib       s             10    inz('*LIBL')
     C     *entry        plist
     C                   parm                    input
     C                   parm                    inl
     C                   parm                    output
      * la lg d'output doit être inl / 2
     c                   eval      inl2 = inl
     C                   eval      unicod = %subst(input:1:inl2)
     c                   eval      outl = inl2 / 2

      * ignorer tous les octets impaires (1,3,5,...)
     c                   do        inl2          z                 4 0
     c     z             div       2             result            4 0
     c                   mvr                     reste             1 0
     c                   if        reste = 0
     c                   eval      i = i + 1
     c                   eval      ebctab(i) = unitab(z)
     c                   endif
     c                   enddo
      * cvt ascii / ebcdic
     c                   call      'QDCXLATE'
     C                   PARM                    outl
     C                   PARM                    ebcdic
     C                   PARM                    qebcdic
     C                   PARM                    qebcdiclib
     c                   eval       %subst(output:1:outl) = ebcdic
     c                   eval       *inlr = *on









              


 QIBM_QTF_Transfert : Transfert de fichiers


 Format TRAN0100 :   - CHAR(10)   Profil utilisateur


                     - CHAR(10)   fonction = '*TFRCTL'


                     - CHAR(10)   action 'SELECT'
                                         'JOIN'
                                         'REPLACE'
                                         'EXTRACT'


                     - CHAR(10)   fichier
                     - CHAR(10)   bibliothèque
                     - CHAR(10)   membre


                     - CHAR(8)    format = 'TRAN0100'


                     - BIN(4)     lg zone suivante


                     - CHAR(??)   requête.

              


 QIBM_QZDA_INIT : lancement de la fonction serveur de données (ODBC)


 Format ZDAI0100     - CHAR(10)   Profil utilisateur


                     - CHAR(10)   fonction = '*SQL'


                     - CHAR(8)    format = 'ZDAI0100'


                     - BIN(4)     toujours à 0


 QIBM_QZDA_NDB1 : fonction serveur de données (ODBC):


 Format ZDAD0100 : (gestion de la base de données)


                     - CHAR(10)   Profil utilisateur


                     - CHAR(10)   fonction = '*NDB'


                     - CHAR(8)    format = 'ZDAD0100'


                     - BIN(4)     action




             actions possibles : 6144 CRTSRCPF
                                 6145 Création d'un fichier (basé sur
                                       un fichier modèle)
                                 6146 Ajout de membre
                                 6147 Mise à blanc d'un membre
                                 6148 Supression d'un membre
                                 6149 OVRDBF
                                 6150 DLTOVR
                                 6153 DLTF


                     - CHAR(128)  Nom du fichier(support des noms longs SQL)


                     - CHAR(10)   Bibliothèque


                     - CHAR(10)   Membre


                     - CHAR(10)   Autorisations (si création)


                     - CHAR(128)  Nom du fichier sur modèle (création)

              

                     - CHAR(10)   Bibliothèque


                     - CHAR(10)   Nom du fichier de substitution


                     - CHAR(10)   Bibliothèque de subsitution


                     - CHAR(10)   membre de substitution


 Format ZDAD0200 : (gestion de la liste de bibliothèques)


                     - CHAR(10)   Profil utilisateur


                     - CHAR(10)   fonction = '*NDB'


                     - CHAR(8)    format = 'ZDAD0200'


                     - BIN(4)     action : 6156 = ADDLIBLE


                     - BIN(4)     nombre de bibliothèques ajoutées


                     - CHAR(??)    liste des bibliothèques ajoutées.

              

 QIBM_QZDA_SQL1 : fonction serveur de données (ODBC):


 Format ZDAQ0100 : (Requêtes SQL via ODBC)


                     - CHAR(10)   Profil utilisateur


                     - CHAR(10)   fonction = '*SQLSRV'


                     - CHAR(8)    format = 'ZDAQ0100'


                     - BIN(4)     action


             actions possibles : code| instruction SQL      
                                 6147 prepare & describe
                                 6148 open
                                 6149 execute
                                 6150 execute immediate
                                 6153 connect (DRDA)
                                 6157 prepare & execute
                                  ou  prepare & open
                                 6158 open & fetch
                                                            A suivre ...

                                 6159 create package
                                 6160 clear package
                                 6161 delete package
                                 6162 execute & open
                                 6166 prepare
                                 6158 open & fetch


                     - CHAR(18)  Nom de l'instruction


                     - CHAR(18)  Nom du curseur


                     - CHAR(2)   options pour PREPARE


                     - CHAR(2)   options pour OPEN


                     - CHAR(10)  Nom du SQL Package


                     - CHAR(10)   Bibliothèque du SQL Package


                     - BIN(2)    DRDA 0 = base locale
                                      1 = remote database

              


                     - CHAR(1)   Type de validation et verrouillage


                                 A = *ALL
                                 C = *CHANGE
                                 N = *NONE
                                 S = *CS


                     - CHAR(512)  512 premiers caractères de la requête.


 QIBM_QZRC_RNT : Remote commande et procédures cataloguées.


 Format CZRC0100 :
                     - CHAR(10)   Profil utilisateur


                     - CHAR(10)   fonction = '*RMTSRV'


                     - CHAR(8)    format = 'CZRC0100'


                     - BIN(4)     action : 1002  remote commande
                                           1003  remote procedure call

              


   pour action 1002 (remote commande)


                     - CHAR(10)    réservé.


                     - BIN(4)      lg de la commande


                     - CHAR(??)    la commande


   pour action 1003 (remote procedure call)


                     - CHAR(10)    programme


                     - CHAR(10)    bibliothèque


                     - BIN(4)      nombre de paramètre


                     - CHAR(??)    paramètres /x fois le découpage suivant:
                                   . BIN(4)   lg de la zone
                                   . BIN(4)   lg maxi
                                   . BIN(2)   1=input,2=output,3=I/O
                                   . CHAR(??) paramètre


             PGM        PARM(&VALID &PARAM)
             DCL        VAR(&VALID) TYPE(*CHAR) LEN(1)
             DCL        VAR(&PARAM) TYPE(*CHAR) LEN(2028)
             DCL        VAR(&message) TYPE(*CHAR) LEN(512)


/*********************************************************************/
/*QIBM_QZDA_... :  serveur de BASE DE DONNéES (TFR ET ODBC)          */
/*                                                                   */
/*                                                                   */
/*********************************************************************/
             CALLPRC    PRC(FILSRVS2) PARM(&PARAM &message)


             if (&message = ' ') then(chgvar &message &param)


             SNDMSG     MSG(&MESSAGE) TOUSR(*SYSOPR)
/* REFUS                                                             */
/*            CHGVAR &VALID '0'                                      */
/* SINON OK                                                          */
             CHGVAR &VALID '1'
             ENDPGM

              

      * =============== copier le source de QSYSINC ======================
      /copy qsysinc.qrpglesrc,EZDAEP
      *===================================================================




         ...  /  ...


      * =============== fin de copie======================================
     Dparam            DS
     D profil                        10
     D serverID                      10
     D format                         8
     D filler                      2000


     dtblaction        s              9B 0 dim(8)
     d                                     ctdata perrcd(1)


     dtblcde           s             10    dim(8)
     d                                     ctdata perrcd(1)


     D i               s              2  0

              


     C     *entry        plist
     C                   parm                    param
     C                   parm                    msg             512




     c                   select
      * connection
     c                   when      format = 'ZDAI0100'
     c                   eval      ezdqif = param
     c                   exsr      connectSR


      * gestion des fichiers
     c                   when      format = 'ZDAD0100'
     c                   eval      ezdndbf1 = param
     c                   exsr      wrkbaseSR


      * gestion de *libl
     c                   when      format = 'ZDAD0200'
     c                   eval      ezdndbf2 = param
     c                   exsr      addliblSR

              

      * extraction d'informations/fichier
     c                   when      format = 'ZDAR0100'
     c                   eval      ezdroif1 = param
     c                   exsr      dspffdSR


      * extraction d'informations(clé primaire)
     c                   when      format = 'ZDAR0200'
     c                   eval      ezdroif2 = param
     c                   exsr      pfcstSR


      * requete SQL (<= 512 octets)
     c                   when      format = 'ZDAQ0100'
     c                   eval      ezdqsqlf  = param
     c                   exsr      sql1SR


      * requete SQL (> 512 octets)
     c                   when      format = 'ZDAQ0200'
     c                   eval      ezdsqlf2 = param
     c                   exsr      sql2SR
     c                   endsl


     c                   return

      *+++
      *+++  sous/pgms
      *+++
     c     connectSR     begsr
     c                   eval      msg = profil + ' se connecte'
     c                   endsr




     c     wrkbaseSR     begsr
     c                   eval      i = 1
     c     EZDFID00      lookup    tblaction(i)                           50
     c                   eval      msg = profil + ' lance la commande ' +
     c                              tblcde(i)
     c                   endsr




     c     addliblSR     begsr
     c                   eval      msg = profil + ' ajoute ' +
     c                              EZDLN00(1) + ' à *libl'
     c                   endsr



              

     c     dspffdSR      begsr
     c                   eval      msg = profil + ' extrait des infos sur '
     c                              + EZDFILN00
     c                   endsr




     c     pfcstSR       begsr
     c                   eval      msg = profil + ' demande la clé de '
     c                              + EZDPKN
     c                   endsr




     c     sql1SR        begsr
     c                   eval      msg = profil + ' exécute la requête '
     c                              + EZDSQLST
     c                   endsr




     c     sql2SR        begsr
     c                   eval      msg = profil + ' exécute la requête '
     c                              + EZDSQLST00
     c                   endsr

** tblaction
000006144
000006145
000006146
000006147
000006148
000006149
000006150
000006153
** tblcde
CRTSRCPF
CRTPF
ADDPFM
CLRPFM
RMVM
OVRDBF
DLTOVR
DLTF







              


 En V4R2 : il y a de nombreux nouveaux points d'exit basés sur TCP/IP


    remarquons QIBM_QTG_DEVINIT démarrage d'une session Telnet
               QIBM_QTG_DEVTERM clôture d'une session Telnet




 QIBM_QTG_DEVINIT




      paramètres recus :


                    1/ User      -> c'est un structure indiquant les
                                     caractèristiques d'une ouverture avec
                                     saut de signon


                       + Binaire (4)   lg de la structure
                       + CHAR(10)      profil à utiliser
                       + CHAR(10)      curlib [val. *USRPRF admise]
                       + CHAR(10)      pgm    [val. *USRPRF admise]
                       + CHAR(10)      menu   [val. *USRPRF admise]

              






                      2/ Device    -> c'est un structure indiquant les
                                       caractèristiques de l'unité à utiliser


                         + CHAR(10)      nom de l'unité
                         + CHAR(8)       format
                                          DSPD0100 = Ecran (seul en V4R2)
                         + CHAR(2)       réservé
                         + BIN(4)        OFFSET pour dspd0100 = 29
                         + BIN(4)        lg de dspd0100 = 12
                         + CHAR(16)      structure DSPD0100 contenant


                                         ° CHAR(3) clavier = FAB en france
                                         ° CHAR(1) réservé
                                         ° BIN(4)  code page = 297
                                         ° BIN(4)  jeux de car. = 697







              


                      3/ infos de connexion (structure)


                         + BIN(4) lg de la structure à suivre


                         + sous-structure contenant l'adresse IP


                             ° CHAR(1) taille de l'adresse en binaire


                             ° CHAR(1) type d'adresse x'02' = IP
                                                      x'06' = IPX


                             ° BIN(2)  n° de port




                             ° CHAR(16) adresse IP constituée de 4 fois
                                        4 octets binaires.


                         + le mot de passe est-il validé ?
                             - 0 = non
                             - 1 = oui (transmis en clair)
                             - 2 = oui (transmis crypté)


                      4/ environnement


                         selon la RFC1572 il est possible de fixer des
                          variables d'environnement pour TELNET
                         (particulièrement dans le monde Unix)


                         cette zone contient en clair les variables
                          d'environnement et leur contenu.


                      5/ lg de la zone environnement


                      6/ connexion


                         0 = rejeté
                         1 = autorisée


                      7/ saut du signon


                         0 = rejeté
                         1 = autorisée

              




  QIBM_QTG_DEVTERM     clôture d'une session TELNET




       paramètres recus :


                     1/ CHAR(10)  nom de l'unité








  Voici un exemple de programme associé à l'initialisation d'une session
   TELNET.


   Il s'agit ici de refuser toute station dont l'adresse IP ne commence
      PAS par 10.3.*


   et d'attribuer des noms significatifs à certains postes (NS en autre)


      (JUIN 98, cela ne marche pas en VT/100  ???)

              


     Dbinaire          S             10I 0
     Dnomvalide        S             10


     Duser             ds
     D  userlg                             like(binaire)
     D  profil                             like(nomvalide)
     D  curlib                             like(nomvalide)
     D  menu                               like(nomvalide)




     Ddevice           ds
     D  unite                              like(nomvalide)
     D  format                        8
     D    filler                      2
     D  offset                             like(binaire)
     D  dspd0100lg                         like(binaire)
     d  dspd0100                     12
     d    clavier                     3    overlay(dspd0100)
     d    codepage                         overlay(dspd0100:5) like(binaire)
     d    charset                          overlay(dspd0100:9) like(binaire)

              


     Dconnection       ds
     D  connectlg                          like(binaire)
     D  adresseclient                20
     D     adrtaille                  1    overlay(adresseclient)
     D     adrtype                    1    overlay(adresseclient:2)
     D     adrport                    2    overlay(adresseclient:3)
     D     adresse                   16    overlay(adresseclient:5)
     D       ip12                     5I 0 overlay(adresse)
     D       ip34                     5I 0 overlay(adresse:3)
     D  password                      1


     D adresseip       c                   x'02'
     D adresseipx      c                   x'06'


     D pas_de_pwd      c                   0
     D pwd_en_clair    c                   1
     D pwd_crypte      c                   2


     Denv              S             32
     Denvlg            S                   like(binaire)

              

     Dconnect          S              1
     D connect_refus   c                   '0'
     D connect_ok      c                   '1'


     Dsaut_signon      S              1
     D saut_refus      c                   '0'
     D saut_ok         c                   '1'


     Dmessage          s           1024
     Dmessagelg        s                   inz(%size(message)) like(binaire)
     Dmessagetype      s             10    inz('*INFO')
     Dmessageq         s             20    inz('PCAF4     *LIBL')
     Dmessageqnb       s                   inz(1) like(binaire)
     DCODERR           DS
     D  LGCOD                              like(binaire)   INZ(16)
     D  LGUTIL                             like(binaire)
     D  MSGID                         7
     D  RESERV                        1


     Dadrchar          ds
     D  dec1                          3  0
     D  dec2                          3  0

     D  dec3                          3  0
     D  dec4                          3  0




     C     *entry        plist
     C                   parm                    user
     C                   parm                    device
     C                   parm                    connection
     C                   parm                    env
     C                   parm                    envlg
     C                   parm                    connect
     C                   parm                    saut_signon


     c     ip12          div       256           dec1
     c                   mvr                     dec2
     c     ip34          div       256           dec3
     c                   mvr                     dec4






     c                   if        dec1 <> 10  or dec2 <> 3
     c                   eval      connect = connect_refus

     c                   else
     c                   eval      connect = connect_ok
     c                   eval      saut_signon = saut_refus


     c                   eval      format = 'DSPD0100'
     c                   eval      offset = 29
     c                   eval      dspd0100lg = 12
     c                   eval      clavier = 'FAB'
     c                   eval      codepage = 297
     c                   eval      charset = 697


     c                   if        dec3 = 1 and dec4 = 5
     c                   eval      unite = 'VTNT'
     c                   endif
     c                   if        dec3 = 1 and dec4 = 9
     c                   eval      unite = 'VTLINUX'
     c                   endif
     c                   if        dec3 = 2 and dec4 = 1
     c                   eval      unite = 'DSPNS'
     c                   endif
     c                   endif

              


     c*
     c* envoi d'un message (voir plus haut) lors de la mise au point .
     c*






     c*                  eval      message = user + '/' + device + '/' +
     c*                            connection + '/' + adrchar
     c*                  call      'QMHSNDBM'
     c*                  parm                    message
     c*                  parm                    messagelg
     c*                  parm                    messagetype
     c*                  parm                    messageq
     c*                  parm                    messageqnb
     c*                  parm                    messageq
     c*                  parm                    coderr


     c                   eval      *inlr = *on




 

début