Bonjour,
Bien que le but de ce forum est plutôt d'aider à répondre à des problèmes que de programmer des sources complets, pour le coup, j'ai quand même pris le temps d'écrire et rapidement tester un COBOL d'alimentation d'une file Websphère MQ.
C'est juste un exemple rapide, qui peut être amélioré, et comme je suis parti d'un Sample IBM (CSQ*.SCSQCOBS : CSQ4BVK1), la programmation pourrait à l'évidence être mieux structurée. En tous cas, ça fonctionne, mais spécifiquement sur MVS.
D'autre part, quand on teste un programme, on s'assure de tous les cas d'erreurs, à commencer les cas de fichiers vides qui réservent souvent des surprises et je n'ai pas pris ce temps.
Ce qui m'intéressait dans cet exemple était que puisque les messages alimentés dans une file MQ sont de longueur variables, on lit un ficher QSAM fixe et non pas variable, de LRECL quelconque pour récupérer cette longueur et en déduire la lonqueur par défaut des messages à écrire par MQPUT.
Pas un truc que l'on fait normamement en COBOL, on prend le LRECL dans le DCB. En contrepartie ça ne peut fonctionner qu'en MVS
Tel que ce programme a peu d'utilité en MVS sans écrire son petit frère (dont je laisse le soin à ceux que ceci intéresseraient), le programme d'extraction des messages alimentés dans la file MQ. Il suffit de repartir d'un exemple de la SCSQCOBS d'install Websphère MQ z/OS (CSQ4BVJ1 en particulier), qu'il est assez facile de reprendre et adapter à ses besoins.
nb. malgré sa spécificité MVS, un tel utilitaire à beaucoup moins d'intérêt en distribué. Je connais bien moins, mais je sais que l'on a alors les outils qui vont bien pour ça.
Enfin, un programme MQ ne peut être compilé qu'avec un JCL de Linkédit particulier. Ceux qui ont le produit en MVS ont nécessairement prévu ceci sur le site.
Code :
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
| CBL NODYNAM
Identification Division.
Program-ID. MQWRITE.
*****************************************************************
* IBM WebSphere MQ for z/OS *
* *
* Module Name : MQWRITE *
* *
* Environment : z/OS Batch; COBOL II *
* *
* Description : Ecriture de messages dans une queue *
* depuis un fichier QSAM lu en SYSIN de *
* LRECL quelconque. *
* *
*****************************************************************
* *
* Exemple JCL d'Appel *
* ------------------- *
* *
* PARM D'APPEL (SEPARES PAR DES VIRGULES) *
* - 1ER PARM (QMGR) NOM QUEUE MANAGER *
* - 2EME PARM (QUEUE) NOM DE LA QUEUE *
* - 3EME PARM (MSGS) NOMBRE DE MESSAGE A ECRIRE A MAXIMUM *
* - 4EME PARM (LEN) LONGUEUR DES MESSAGES (DEFAUT = LRECL) *
* LONGUEUR MAXI : 65535 *
* - 5EME PARM (PERS) MESSAGES (P)ERSISTENTS/(N)ON PERSISTENT*
*---------------------------------------------------------------*
* //PUTMSGS EXEC PGM=MQWRITE,REGION=1024K, *
* // PARM=('CSQ7,TESTFILE,2,20,P') *
* //STEPLIB DD DSN=&SYSUID..COBOL.LOADLIB,DISP=SHR *
* DD DISP=SHR,DSN=CSQ700.SCSQAUTH *
* DD DISP=SHR,DSN=CSQ700.SCSQANLE *
* //SYSOUT DD SYSOUT=* *
* //SYSPRINT DD SYSOUT=* *
* //SYSIN DD * *
* MESSAGE NO 000001 *
* MESSAGE NO 000002 *
* *
*****************************************************************
* *
* Logique programme *
* ----------------- *
* *
* *
* Move paramètres dans les variables correspndantes *
* si erreur -> Call USAGE-ERROR et retour *
* *
* Open fichier SYSIN et chargement du LRECL depuis son DCB *
* si erreur -> Call USAGE-ERROR et retour *
* *
* Display des parametres reçus par le programme *
* *
* Connect Queue manager. *
* si erreur -> Call DISPLAY-ERROR-MESSAGE et retour *
* *
* Affectation des options pour l'OPEN . *
* MQOPEN de la file message *
* si erreur -> Disconnect *
* -> Call DISPLAY-ERROR-MESSAGE et retour *
* *
* Affectation des propriétés et options messages *
* *
* Display du nombre de messages écrits *
* *
* Close puis Disconnect Queue manager *
* si erreur -> Call DISPLAY-ERROR-MESSAGE *
* *
* Exit program. *
* *
* *
*****************************************************************
Environment Division.
Input-Output Section.
File-Control.
Select MYMESS Assign to SYSIN.
Data Division.
File Section.
FD MYMESS
Recording Mode is F
Record 0.
01 ENR-MYMESS Pic X(32760).
* ------------------------------------------------------------- *
Working-Storage Section.
* ------------------------------------------------------------- *
* Données de travail général
01 W0-PTRX Pic x(4) Value Low-Value.
01 W0-PTR Redefines W0-PTRX Pointer.
01.
05 W0-LRECL-MAXI Pic S9(8) Binary Value 65535.
05 W0-COUNT-LEC Pic S9(4) Binary Value Zero.
05 W0-LECT-FIN Pic S9(4) Binary Value Zero.
05 W0-RETURN-CODE Pic S9(4) Binary.
05 W0-LOOP Pic S9(4) Binary Value 0.
05 W0-NUMPUTS Pic S9(4) Binary Value 0.
05 W0-ERROR-MESSAGE Pic X(48) Value Spaces.
* Variables paramètres
01 W0-QMGR Pic X(48).
01 W0-QNAME Pic X(48).
01 W0-NUMMSGS-NUM Pic 9(04) Value 0.
01 W0-NUMMSGS Pic S9(4) Binary.
01 W0-MSGLENGTH-NUM Pic 9(04) Value 0.
01 W0-MSGLENGTH Pic S9(9) Binary.
01 W0-PERSISTANCE Pic X(1) Value 'N'.
88 PERSISTENT Value 'P'.
88 NOT-PERSISTENT Value 'N'.
* W03 - API fields
01 W3-HCONN Pic S9(9) Binary Value 0.
01 W3-HOBJ Pic S9(9) Binary Value 0.
01 W3-OPENOPTIONS Pic S9(9) Binary.
01 W3-COMPCODE Pic S9(9) Binary.
01 W3-REASON Pic S9(9) Binary.
* API control blocks
01 MQM-OBJECT-DESCRIPTOR.
COPY CMQODV.
01 MQM-MESSAGE-DESCRIPTOR.
COPY CMQMDV.
01 MQM-PUT-MESSAGE-OPTIONS.
COPY CMQPMOV.
* MQV : constantes de remplissage des blocs de controle
* et codes retours à tester après les oall (et finis)
01 MQM-CONSTANTS.
* --COPY CMQV.
COPY CMQV SUPPRESS.
* ------------------------------------------------------------- *
Linkage Section.
* ------------------------------------------------------------- *
01 PARM-RECU.
05 PARM-LEN Pic S9(03) Binary.
05 PARM-DATA Pic X(100).
* MACRO DCBD en ASM : CSECT IHADCB
01 DCB-WORK.
05 Pic x(62).
05 DCB-BLKSZ Pic s9(4) Binary.
05 Pic x(18).
05 DCB-LRECL Pic s9(4) Binary.
05 Pic x(04).
EJECT
* ------------------------------------------------------------- *
Procedure Division Using PARM-RECU.
* ------------------------------------------------------------- *
If PARM-LEN = 0 THEN
* parametres absents ! inutile de continuer.
Display "* ==========================================="
Display "* PARAMETRES NON COMMUNIQUES !"
Display "* PARM='QMGR,QNAME,0,MSGLEN,P/N' PERSISTANCE"
Display "* ==========================================="
Move 8 to W0-RETURN-CODE
Go To RETOUR
End-if
Move 0 To W0-RETURN-CODE
Unstring PARM-DATA Delimited By All ','
Into W0-QMGR
W0-QNAME
W0-NUMMSGS-NUM
W0-MSGLENGTH-NUM
W0-PERSISTANCE
* Contrôle des paramètres reçus et affectation des défauts
If Not PERSISTENT
Set NOT-PERSISTENT to true
End-if
If W0-NUMMSGS-NUM not numeric
or W0-NUMMSGS-NUM = Zero
Move 9999 to W0-NUMMSGS-NUM
End-if
Move W0-NUMMSGS-NUM to W0-NUMMSGS
If W0-MSGLENGTH-NUM not Numeric
or W0-MSGLENGTH-NUM = Zero
Move W0-LRECL-MAXI to W0-MSGLENGTH-NUM
End-if
Open Input MYMESS
* Adressage du DCB pour avoir le LRECL du fichier lu
* LRECL = DCB + x'52'
Call 'QUELDCB' Using MYMESS W0-PTRX
Set Address of DCB-WORK to W0-PTR
If DCB-LRECL < W0-MSGLENGTH-NUM
Move DCB-LRECL to W0-MSGLENGTH-NUM
if W0-MSGLENGTH-NUM = zero
* LRECL = 80 si non précisé (DD *)
Move 80 to W0-MSGLENGTH-NUM
end-if
End-if
If W0-MSGLENGTH-NUM > W0-LRECL-MAXI
And W0-LRECL-MAXI > Zero
Move W0-LRECL-MAXI to W0-MSGLENGTH-NUM
End-if
Move W0-MSGLENGTH-NUM to W0-MSGLENGTH
Display '* ==========================================='
Display '* PARAMETRES TRAITES :'
Display '* QMGR - ', W0-QMGR
Display '* QNAME - ', W0-QNAME
Display '* NUMMSGS - ', W0-NUMMSGS
Display '* MSGLENGTH - ', W0-MSGLENGTH
Display '* PERSISTANCE - ', W0-PERSISTANCE
Display '* ==========================================='
* Connect queue manager
Call 'MQCONN' Using W0-QMGR
W3-HCONN
W3-COMPCODE
W3-REASON
* Vérification si MQ est bien lancé
If W3-REASON = MQRC-Q-MGR-not-AVAILABLE then
Display '* ==========================================='
Display "* WEBSPHERE-MQ N'EST PAS DISPONIBLE !"
Display "* LE LANCER : /%" W0-QMGR(1:8) " START QMGR"
Display "* /%" W0-QMGR(1:8) " START CHINIT"
Display "* PUIS RELANCER LE PROGRAMME MQWRITE"
Display '* ==========================================='
Move 8 to W0-RETURN-CODE
Go to FIN-DU-PROGRAMME
End-if
If (W3-COMPCODE not = MQCC-OK) THEN
Move 'MQCONN' to W0-ERROR-MESSAGE
Perform DISPLAY-ERROR-MESSAGE
Move W3-REASON to W0-RETURN-CODE
Go to FIN-DU-PROGRAMME
End-if
* Open de la file en output. Erreur CALL si queue en quiesce
Compute W3-OPENOPTIONS = MQOO-Output +
MQOO-FAIL-If-QUIESCING
Move W0-QNAME to MQOD-OBJECTNAME
*
Call 'MQOPEN' Using W3-HCONN
MQOD
W3-OPENOPTIONS
W3-HOBJ
W3-COMPCODE
W3-REASON
* Si Erreur OPEN, Message = Lecture forcée à zéro
If (W3-COMPCODE not = MQCC-OK)
Move 'MQOPEN' to W0-ERROR-MESSAGE
Perform DISPLAY-ERROR-MESSAGE
Move 0 to W0-NUMMSGS
End-if
If PERSISTENT THEN
Move MQPER-PERSISTENT to MQMD-PERSISTENCE
Else
Move MQPER-not-PERSISTENT to MQMD-PERSISTENCE
End-if
Move MQFMT-String to MQMD-FORMAT
* put message options en erreur si queue manager quiescing
Move MQPMO-FAIL-If-QUIESCING to MQPMO-OPTIONS
Perform WITH TEST BEFORE Varying W0-LOOP From 0 By 1
Until (W0-LOOP >= W0-NUMMSGS)
If W0-LECT-FIN = 0
Read MYMESS
AT End
Move W0-COUNT-LEC to W0-LECT-FIN
Add 1 W0-NUMMSGS to W0-LOOP
not AT End
Add 1 to W0-COUNT-LEC
End-READ
End-if
If W0-LOOP not > W0-NUMMSGS
Move MQMI-NONE to MQMD-MSGID
Move MQCI-NONE to MQMD-CORRELID
Call 'MQPUT' Using W3-HCONN
W3-HOBJ
MQMD
MQPMO
W0-MSGLENGTH
ENR-MYMESS
W3-COMPCODE
W3-REASON
* Si ERREUR MQPUT, Message d'erreur et sortie forcée
If W3-COMPCODE = MQCC-OK
Add 1 to W0-NUMPUTS
Else
Move 'MQPUT' to W0-ERROR-MESSAGE
Perform DISPLAY-ERROR-MESSAGE
Move W3-REASON to W0-RETURN-CODE
Add 1 W0-NUMMSGS to W0-LOOP
End-if
End-if
End-Perform
* Close queue manager si on a écrit des messages
If W0-NUMMSGS > 0
Display '* MESSAGES LUS = ' W0-COUNT-LEC
' - MESSAGES ECRITS = ' W0-NUMPUTS
Display '* ==========================================='
Call 'MQCLOSE' Using W3-HCONN
W3-HOBJ
MQCO-NONE
W3-COMPCODE
W3-REASON
If (W3-COMPCODE not = MQCC-OK) THEN
Move 'MQCLOSE' to W0-ERROR-MESSAGE
Perform DISPLAY-ERROR-MESSAGE
Move W3-REASON to W0-RETURN-CODE
End-if
End-if
* Disconnect from the queue manager
Call 'MQDISC' Using W3-HCONN
W3-COMPCODE
W3-REASON
If (W3-COMPCODE not = MQCC-OK) THEN
Move 'MQDISC' to W0-ERROR-MESSAGE
Perform DISPLAY-ERROR-MESSAGE
Move W3-REASON to W0-RETURN-CODE
End-if.
FIN-DU-PROGRAMME.
Close MYMESS.
RETOUR.
Move W0-RETURN-CODE to Return-Code
Goback.
*
* ------------------------------------------------------------- *
DISPLAY-ERROR-MESSAGE.
* ------------------------------------------------------------- *
*
Display '************************************************'
Display '* ERREUR ' W0-ERROR-MESSAGE
Display '* COMPLETION CODE : ' W3-COMPCODE
Display '* REASON CODE : ' W3-REASON
Display '************************************************'
.
*
* ===============================================================
Identification Division.
PROGRAM-ID. QUELDCB.
*==============================================================*
* module interne pour adressage d'une zone d'un Cobol hors de *
* la Working Storage. Rend l'adresse de la zone passée. *
*==============================================================*
Data Division.
Linkage Section.
*================
01 LS-INPUT pic x.
01 LS-OUTPUT pointer.
*===================
Procedure Division Using LS-INPUT LS-OUTPUT.
*===================
Set LS-OUTPUT to address of LS-INPUT
Goback.
End Program QUELDCB.
End Program MQWRITE. |
08/10/2009, 18h07
Insertion dans une file d'attente MQSERIS
00
