IDENTIFICATION DIVISION.
PROGRAM-ID. RXSDO.
*** Morten Boegh http://www.rxs.se
* RXS FORTOLKER: LOADMODUL
* 2006-02-17 '%' er gjort til SPEC-CHAR.
* 2006-03-02 MQ: Der kan kommunikeres messages på 3M begge veje
* 2006-06-01 MQ: PUTDATE, PUTTIME, APPLNAME og APPLTYPE tilføjet
* 2006-09-04 version 2006-06-06 ophøjet til gældende, dvs
* to rettelser ved XML er væk igen:
* inddata strenges ikke helt simpelt sammen for at
* undgå problemer med '<' i starten af linien når
* white-space fjernes
* fjernelse af namespace kvalifikation i xml
* 2007-01-18 FEJLUDX lagt inline
* MQ copyarealer lagt inline
* 2007-02-15 ZWINTTL gøres ikke global
* 2007-03-21 WS-XML-TEXT er nu 500000 byte
* (dvs max value i en tag: 500000 byte
* max value i attribut: 1000 byte
* max længde af tag-navn og attribut-navn: 1000 byte)
* NB: der mangler fejlmedd. hvis disse længder brydes
* 2007-05-02 namespace_1 namespace_2: gør ikke global
* 2007-06-26 INPUT-SHARED ej option ved browse: ødelagde racf-read
* (dvs: hvis man kun har read access kan man
* ikke læse i browse hvis der køres input-shared)
* 2008-01-13 INFILE ej i explist
* 2009-02-02 UNIX tilføjet, UTF-8 tilføjet
* 2010-01-22 UNIX: READNL udgår
* 2010-03-13 Rettelse af to fejl i opsat laengde (se dato)
* 2010-03-18 Diverse SSRANGE problemer
* 2010-03-24; TEKST-IS-TEXT-ENDTEXT-MARK indført for at få
* )TEXT og )ENDTEXT venstrestillet (mystisk problem,
* fandtes ikke før 2010-03-18
* 2010-05-21 RXSINP-INDIVID occurs 8004 isf 8000
* 2010-05-28 Option MAKENL i UNIX-behandling fjernet (flyttet til RXS)
* 2010-10-25 XML ændret til COBOL 4.2
* 2011-01-12 håndtering er længde nul i diverse konvertering
* 2011-03-17 UTF8 konvertering: håndter karakter der deles i
* buffer-grænse
* 2011-03-24 UTF8 konvertering mv. rettet: nu sendes (igen)
* hele filen fra RXS til RXSDO inden konvertering sker
* 2011-05-21 RXSINP-INDIVID: char occurs nu også 8004
* 2011-06-09 Fejlmeld linier med ubalancerede quotes
* 2011-08-24 Der håndteres max 16 MB i XML og MQ
* 2011-08-31 XML læses nu flydende ind, dvs begrænsning ligger i RXS
* 2011-10-04 "...THEN DROPQUEUE" håndteres
* 2012-05-29 ")interface" lagt ind
* 2012-05-30 WS-TEXT-LEVEL: occcurs 500
* 2013-01-20 IF tilføjet
* 2013-04-09 ws-status occurs 1000
* 2013-10-08 )& sendes uændret igennem
* 2013-10-18 SET_HALT og SET_MESSAGE omdannes til CALL - også efter THEN
* 2015-03-11 UTF8 check på dobbeltbyte etc til sidst: ikke for
* korte strenge
* 2015-12-22 )& : Variable i linien puttes i )EXP
* 2016-05-30 Hvis en attribut er tom, tildeler vi den værdien blank
* 2017-02-16 Problem med sidste linie lig ' )endaction'
* 2017-02-16 INSQL accepteres som global order
* 2017-07-24 Continuation med )+ sendes uændret igennem
* 2018-01-02 )NOP og )INTERFACE: sæt RX-DER-SKAL-FORTOLKES
* problemet er at )NOP og )INTERFACE udenfor )ACTION
* og ikke i kolonne 1, ikke blev fortolket i den
* nugældende løsning
* 2018-05-04 FEJLMELD-ANT-EXPLIST hvis over 500 variable findes
* 2018-06-06 Kodning vedr EXPLIST flyttet til efter OPEN RXSOUTP
* 2020-03-08 GROV-FEJL-FUNDET: Kontrol stopper efter første fundne fejl
* (Heruder: stop kotrol hvis WS-LVL er < 1)
* 2020-08-28 XML: LAES-INPUT saneret. Gav fejl i ekstreme situationer
* 2020-11-05 XML Fjern whitespace hvis linie slutter med afsluttet tag
* Eller starter med start-tag
* Dog ikke hvis RXS har delt op i individer a 7999 byte
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SPECIAL-NAMES.
CLASS OPERA-CHAR '>' '<' '=' '^'
CLASS SPEC-CHAR
'/' '*' '>' '<' '=' '^' '(' ')' '.' ',' '|' '&' ';'
'+' '-' '%'
CLASS QUOTE-CHAR '"' "'"
CLASS UTF8-TWO-BYTE X'C2' THRU X'CE', X'D0' THRU X'DF'
CLASS UTF8-THREE-BYTE X'E0' THRU X'EF'
CLASS UTF8-FOUR-BYTE X'F0' THRU X'FF'
.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT RXSINP ASSIGN TO RXSINP.
SELECT RXSOUTP ASSIGN TO RXSOUTP.
DATA DIVISION.
FILE SECTION.
FD RXSINP GLOBAL RECORD VARYING FROM 1 TO 8004 DEPENDING ON
RXSINP-LGTH
BLOCK 0 RECORDING MODE V.
01 RXSINP-INDIVID.
03 RXSINP-CHAR PIC X OCCURS 8004 DEPENDING ON WSRXSINP-LGTH.
FD RXSOUTP GLOBAL RECORD VARYING FROM 1 TO 8004 DEPENDING ON
RXSOUTP-LGTH
BLOCK 0 RECORDING MODE V.
01 RXSOUTP-INDIVID.
02 RXSSOUT-CHAR PIC X OCCURS 8004 DEPENDING ON WSRXSOUTP-LGTH.
WORKING-STORAGE SECTION.
01 LIBRATID PIC X(24) LIBRATID
VALUE 'LIBRATIDLIBRATIDLIBRATID'. LIBRATID
01 FILLER REDEFINES LIBRATID. LIBRATID
02 LT-PGMID-DTO-VERSION. LIBRATID
03 LT-PGMID PIC X(8). LIBRATID
03 LT-DTO-VERSION. LIBRATID
04 LT-DTO PIC X(6). LIBRATID
04 LT-VERSION PIC X(2). LIBRATID
02 LT-TID PIC X(8). LIBRATID
* skal være 'unsigned':
01 RXSINP-LGTH PIC 9(4) COMP GLOBAL.
01 RXSOUTP-LGTH PIC 9(4) COMP GLOBAL.
01 WSRXSINP-LGTH PIC S9(8) COMP GLOBAL.
01 WSRXSOUTP-LGTH PIC S9(8) COMP GLOBAL.
01 WS-PARM-G.
02 WS-PARM-LGTH PIC S9(4) COMP.
02 WS-PARM PIC X(31500).
01 WS-WHEN-COMPILED PIC X(21).
01 WS-WHEN-COMP-DATO PIC X(50).
01 CEE3ABD-ABDCODE PIC S9(9) BINARY.
01 CEE3ABD-TIMING PIC S9(9) BINARY.
LINKAGE SECTION.
01 LINK-PARM-G.
02 LINK-PARM-LGTH PIC S9(4) COMP.
02 LINK-PARM PIC X(31500).
PROCEDURE DIVISION USING LINK-PARM-G.
IF LINK-PARM-LGTH > 2
COMPUTE WS-PARM-LGTH = LINK-PARM-LGTH - 2
MOVE LINK-PARM(3:WS-PARM-LGTH) TO WS-PARM
ELSE
MOVE ZERO TO WS-PARM-LGTH
END-IF
EVALUATE LINK-PARM(1:1)
WHEN 'P'
CALL 'RXSPGM' USING WS-PARM-G
WHEN 'X'
CALL 'RXSXML' USING WS-PARM-G
WHEN 'Q'
CALL 'RXSMQ' USING WS-PARM-G
WHEN 'C'
CALL 'RXSCONV' USING WS-PARM-G
WHEN 'V'
OPEN OUTPUT RXSOUTP
MOVE 1 TO WSRXSOUTP-LGTH
RXSOUTP-LGTH
MOVE FUNCTION WHEN-COMPILED TO WS-WHEN-COMPILED
STRING WS-WHEN-COMPILED(1:4) '-'
WS-WHEN-COMPILED(5:2) '-'
WS-WHEN-COMPILED(7:2)
DELIMITED BY SIZE INTO WS-WHEN-COMP-DATO
POINTER WSRXSOUTP-LGTH
SUBTRACT 1 FROM WSRXSOUTP-LGTH
MOVE WSRXSOUTP-LGTH TO RXSOUTP-LGTH
MOVE WS-WHEN-COMP-DATO(1:WSRXSOUTP-LGTH)
TO RXSOUTP-INDIVID
WRITE RXSOUTP-INDIVID
CLOSE RXSOUTP
END-EVALUATE
GOBACK.
* -----RXSPGM---------------------------------------------
IDENTIFICATION DIVISION.
PROGRAM-ID. RXSPGM.
*
* Omform RXS til REXX mm - forfase
*
* SDBSTEST.SLUTSTND.LIBRA
*
* NB: COBOL-370/390/ENTERPRISE
*
* OPRETTET DEN 09/02-03 AF I2287
*
*
* Analyse af den enkelte rexx-sætning, tegn for tegn:
* ==================================================
* B blank
* R REXX ord
* r REXX ord (hvis første ord, må der ikke genereres linienr)
* N numerisk værdi
* O Operator (= > < etc)
* F Navn på funktion i rexx
* C Comment
* Q Quoted string
* S Specialkarakter (* & etc)
* V Brugerdefineret variabel
*
* Struktur i output:
* =================
* )EXP her er explist
* )ERR LINNR ..fejlmeddelelse..
* Øvrige linier: let omformet input (alle ')' genfindes)
*
* 2003-02-20: kommentarlininer og blanke linier: uden linienr
*
* 2003-08-21: support for )TEXT )ENDTEXT
* 2003-09-03: User exit giver kald af USER_EXIT
* 2004-04-04: )TEXT udsættes ikke for konkatenering
* 2004-04-04: Blanke i input overføres
* 2004-10-07: Ikke-afsluttet kommentarblok fejlmeldes
* 2004-10-07: RXS blok kommando i continuated linie fejlmeldes
* 2005-06-06: dropqueue accepteres som 'instruktion' dvs uden call
* make_global accepteres som 'instruktion' dvs uden call
* omsættes til CALL RX_Q hhv. CALL RX_GLB
DATA DIVISION.
WORKING-STORAGE SECTION.
01 LIBRATID PIC X(24) LIBRATID
VALUE 'LIBRATIDLIBRATIDLIBRATID'. LIBRATID
01 FILLER REDEFINES LIBRATID. LIBRATID
02 LT-PGMID-DTO-VERSION. LIBRATID
03 LT-PGMID PIC X(8). LIBRATID
03 LT-DTO-VERSION. LIBRATID
04 LT-DTO PIC X(6). LIBRATID
04 LT-VERSION PIC X(2). LIBRATID
02 LT-TID PIC X(8). LIBRATID
01 WSRXSINP-INDIVID.
02 WSRXSINP-CHAR PIC X OCCURS 8000.
01 WSRXSOUTP-INDIVID.
02 WSRXSOUTP-CHAR PIC X OCCURS 8000.
01 EOF-SW PIC X.
01 IX PIC S9(4) COMP.
01 IXIX PIC S9(4) COMP.
01 IXX PIC S9(4) COMP.
01 IXXX PIC S9(4) COMP.
01 WX PIC S9(4) COMP.
01 WXX PIC S9(4) COMP.
01 QUOTESW PIC X.
01 COMMSW PIC X.
01 IN-STATU-G.
02 IN-STATU PIC X OCCURS 4000.
01 IFORR PIC S9(4) COMP.
01 IXLOK PIC S9(4) COMP.
01 LOKALSW PIC X.
01 FIRST-WORD-G.
02 FIRST-WORD PIC X OCCURS 200.
01 FIRST-OPERATOR-G.
02 FIRST-OPERATOR PIC X OCCURS 200.
01 WS-POINTER-G.
02 WS-POINTER PIC S9(4) COMP OCCURS 1000.
01 IXLGTH PIC S9(4) COMP.
01 IXFORR PIC S9(4) COMP.
01 WS-STATUS-G.
02 WS-STATUS PIC X OCCURS 1000.
01 WS-START-LVL PIC 999.
01 CONCATENATE-POINTER PIC S9(4) COMP VALUE +1.
01 CONCATENATE-LINE PIC X(4000).
01 CONCATENATE-LENGTH PIC S9(4) COMP.
01 HVOR-ER-VI-SW PIC X.
01 WS-TEMP-LVL PIC S9(4) COMP.
01 WS-LVL PIC S9(4) COMP.
01 LEVEL-TYPE-G.
02 LEVEL-TYPE PIC X OCCURS 500.
01 RX-DER-SKAL-FORTOLKES PIC X.
01 RX-SW-INPUT-DATA PIC X.
01 WS-EXPLIST-G.
02 WS-EXPLIST-ELM PIC X(250) OCCURS 500
DEPENDING ON WS-EXPLIST-ANT
INDEXED BY EXPIDX.
01 WS-EXPLIST-ANT PIC S9(4) COMP.
01 Z1 PIC S9(4) COMP.
01 Z2 PIC S9(4) COMP.
01 WS-RES-EXPLIST PIC X(4000).
01 WS-RES-EXPLIST-PTR PIC S9(4) COMP.
01 WS-USERVAR PIC X(255).
01 WS-USERVAR2 PIC X(255).
01 LOKSTRING PIC X(15).
01 WSRXSINP-STRT PIC S9(4) COMP.
* skal være 'unsigned':
01 WS-LINNR-B PIC 9(8) COMP.
01 WS-LINNR-RED PIC ZZZZ9.
01 WS-LINNR PIC XXXXX.
01 WS-NOP-LINNR PIC XXXXX.
01 SPECIAL-ORD-SW PIC X.
01 SPECIAL-ORD-START PIC S9(4) COMP.
01 WSTEMP-INDIVID PIC X(4000).
01 IXNOTBL PIC S9(4) COMP.
01 SPECIAL-ORD-NUMMER PIC S9(4) COMP.
01 EQUALS-FUNDET-SW PIC X.
01 WS-NEXTCHAR PIC X.
01 WS-TEXT-LEVEL-G.
02 WS-TEXT-LEVEL PIC S9(4) COMP OCCURS 500.
01 WS-GEM-COMMENT-START PIC XXXXX.
01 CALL-SW PIC X.
01 TEKST-IS-TEXT-ENDTEXT-MARK PIC X.
01 GROV-FEJL-FUNDET PIC X.
LINKAGE SECTION.
01 LINK-PARM-G.
02 LINK-PARM-LGTH PIC S9(4) COMP.
02 LINK-PARM PIC X(31500).
PROCEDURE DIVISION USING LINK-PARM-G.
MOVE 1 TO WS-TEMP-LVL
WS-LVL
OPEN INPUT RXSINP
OPEN OUTPUT RXSOUTP
MOVE ' ' TO EOF-SW
MOVE SPACES TO IN-STATU-G
MOVE SPACE TO COMMSW
MOVE 0 TO WS-LINNR-B
MOVE SPACES TO WS-NOP-LINNR
move ' ' to GROV-FEJL-FUNDET
MOVE 'N' TO RX-DER-SKAL-FORTOLKES
MOVE '1' TO RX-SW-INPUT-DATA
* kodning flyttet hertil 2018-06-06:
MOVE ZERO TO WS-EXPLIST-ANT
MOVE 1 TO Z1
PERFORM UNTIL Z1 > LINK-PARM-LGTH
OR WS-EXPLIST-ANT > 501
ADD 1 TO WS-EXPLIST-ANT
IF WS-EXPLIST-ANT > 500
PERFORM FEJLMELD-ANT-EXPLIST
END-IF
MOVE SPACES TO WS-EXPLIST-ELM(WS-EXPLIST-ANT)
UNSTRING LINK-PARM(1: LINK-PARM-LGTH) DELIMITED
BY ALL SPACES INTO WS-EXPLIST-ELM(WS-EXPLIST-ANT)
POINTER Z1
IF WS-EXPLIST-ELM(WS-EXPLIST-ANT) = SPACES
MOVE 30000 TO Z1
END-IF
END-PERFORM
PERFORM UNTIL EOF-SW = '1'
READ RXSINP
AT END
MOVE '1' TO EOF-SW
NOT AT END
MOVE RXSINP-LGTH TO WSRXSINP-LGTH
ADD 1 TO WS-LINNR-B
MOVE WS-LINNR-B TO WS-LINNR-RED
EVALUATE TRUE
WHEN WS-LINNR-B < 10
MOVE WS-LINNR-RED(5:1) TO WS-LINNR
WHEN WS-LINNR-B < 100
MOVE WS-LINNR-RED(4:2) TO WS-LINNR
WHEN WS-LINNR-B < 1000
MOVE WS-LINNR-RED(3:3) TO WS-LINNR
WHEN WS-LINNR-B < 10000
MOVE WS-LINNR-RED(2:4) TO WS-LINNR
WHEN ANY
MOVE WS-LINNR-RED TO WS-LINNR
END-EVALUATE
MOVE 1 TO WSRXSOUTP-LGTH
PERFORM HVOR-ER-VI
if rxsinp-lgth > 0
PERFORM CONCATENATE-CONTINUATION
else
if concatenate-pointer = 1
move zero to wsrxsinp-lgth
move spaces to wsrxsinp-individ
end-if
end-if
IF GROV-FEJL-FUNDET = ' '
IF WS-LVL > 0
PERFORM FIND-TYPE-AF-LINIE
END-IF
END-IF
END-READ
END-PERFORM
PERFORM CHECK-AFSLUTNING-AF-BLOKKE
PERFORM CHECK-AFSLUTNING-AF-COMMENT
PERFORM DAN-EXPLIST
CLOSE RXSINP
CLOSE RXSOUTP
MOVE ZERO TO RETURN-CODE
.
GOBACK.
HVOR-ER-VI SECTION.
* section har vist kun til formål at afgøre om der kan
* concateneres med ',' eller ej
*
* RX-DER-SKAL-FORTOLKES: 'J' Der skal fortolkes
* 'N' Der skal ikke fortolkes
* tomme linier:
* IF RXSINP-LGTH < 2
* MOVE 4 TO RXSINP-LGTH
* END-IF
* ignore leading spaces:
MOVE 1 TO IXNOTBL
PERFORM VARYING IXX FROM 1 BY 1 UNTIL IXX > RXSINP-LGTH
IF RXSINP-CHAR(IXX) = ' '
ADD 1 TO IXNOTBL
ELSE
* MOVE 9999 TO IXX
COMPUTE IXX = RXSINP-LGTH + 1
END-IF
END-PERFORM
IF IXNOTBL > RXSINP-LGTH
MOVE RXSINP-LGTH TO IXNOTBL
END-IF
MOVE 'N' TO TEKST-IS-TEXT-ENDTEXT-MARK
EVALUATE TRUE
* 2010-03-18 when rettet fra RXSINP-LGHT > x:
WHEN RXSINP-LGTH - IXNOTBL + 1 > 6
AND FUNCTION UPPER-CASE(RXSINP-INDIVID(IXNOTBL:7))
= ')ACTION'
ADD 1 TO WS-TEMP-LVL
MOVE 'A' TO LEVEL-TYPE(WS-TEMP-LVL)
MOVE 'J' TO RX-DER-SKAL-FORTOLKES
WHEN RXSINP-LGTH - IXNOTBL + 1 > 4
AND FUNCTION UPPER-CASE(RXSINP-INDIVID(IXNOTBL:5))
= ')TEXT'
ADD 1 TO WS-TEMP-LVL
MOVE 'T' TO LEVEL-TYPE(WS-TEMP-LVL)
MOVE 'N' TO RX-DER-SKAL-FORTOLKES
MOVE 'J' TO TEKST-IS-TEXT-ENDTEXT-MARK
WHEN RXSINP-LGTH - IXNOTBL + 1 > 9
AND FUNCTION UPPER-CASE(RXSINP-INDIVID(IXNOTBL:10))
= ')ENDACTION'
SUBTRACT 1 FROM WS-TEMP-LVL
* 2017-02-16: problem med RXS ender med ' )endaction':
* (næste linie tilføjet)
MOVE 'J' TO RX-DER-SKAL-FORTOLKES
WHEN RXSINP-LGTH - IXNOTBL + 1 > 7
AND FUNCTION UPPER-CASE(RXSINP-INDIVID(IXNOTBL:8))
= ')ENDTEXT'
SUBTRACT 1 FROM WS-TEMP-LVL
MOVE 'J' TO TEKST-IS-TEXT-ENDTEXT-MARK
WHEN RXSINP-LGTH - IXNOTBL + 1 > 7
AND FUNCTION UPPER-CASE(RXSINP-INDIVID(IXNOTBL:8))
= ')DEFAULT'
MOVE 'J' TO RX-DER-SKAL-FORTOLKES
WHEN RXSINP-LGTH - IXNOTBL + 1 > 5
AND FUNCTION UPPER-CASE(RXSINP-INDIVID(IXNOTBL:6))
= ')IMBED'
MOVE 'J' TO RX-DER-SKAL-FORTOLKES
* 2013-10-17: (rettet 2017-07-24:)
WHEN RXSINP-LGTH - IXNOTBL + 1 > 2
AND (FUNCTION UPPER-CASE(RXSINP-INDIVID(IXNOTBL:2))
= ')&' OR ')+'
)
MOVE 'N' TO RX-DER-SKAL-FORTOLKES
WHEN WS-TEMP-LVL > 1 AND LEVEL-TYPE(WS-TEMP-LVL) = 'A'
MOVE 'J' TO RX-DER-SKAL-FORTOLKES
* 2018-01-02 start:
WHEN RXSINP-LGTH - IXNOTBL + 1 > 9
AND FUNCTION UPPER-CASE(RXSINP-INDIVID(IXNOTBL:10))
= ')INTERFACE'
MOVE 'J' TO RX-DER-SKAL-FORTOLKES
WHEN RXSINP-LGTH - IXNOTBL + 1 > 3
AND FUNCTION UPPER-CASE(RXSINP-INDIVID(IXNOTBL:4))
= ')NOP'
MOVE 'J' TO RX-DER-SKAL-FORTOLKES
* 2018-01-02 slut
WHEN ANY
* dvs der må ikke konkateneres linier:
MOVE 'N' TO RX-DER-SKAL-FORTOLKES
END-EVALUATE
.
HVOR-ER-VI-EX.
EXIT.
CONCATENATE-CONTINUATION SECTION.
* resultat: linier som ender med ',' blankes ud, længde nul,
* og akkumuleres til en samlet linie når continuation er slut
* tilsvarende med THEN etc
* - regelsættet måske ikke helt korrekt vedr. kommentarer
* (hvis linie afsluttes med kommentarblok efter continuation)
IF RX-DER-SKAL-FORTOLKES = 'J' OR CONCATENATE-POINTER > 1
IF (RXSINP-INDIVID(RXSINP-LGTH : 1) = ','
OR (RXSINP-LGTH > 5 AND
FUNCTION UPPER-CASE(
RXSINP-INDIVID(RXSINP-LGTH - 4: 5)) = ' THEN')
OR (RXSINP-LGTH > 5 AND
FUNCTION UPPER-CASE(
RXSINP-INDIVID(RXSINP-LGTH - 4: 5)) = ' ELSE')
OR (RXSINP-LGTH > 10 AND
FUNCTION UPPER-CASE(
RXSINP-INDIVID(RXSINP-LGTH - 9: 10)) = ' OTHERWISE')
)
* AND RX-SW-INPUT-DATA = ' '
IF RXSINP-INDIVID(RXSINP-LGTH : 1) = ','
COMPUTE CONCATENATE-LENGTH = RXSINP-LGTH - IXNOTBL
ELSE
COMPUTE CONCATENATE-LENGTH = RXSINP-LGTH - IXNOTBL + 1
END-IF
if concatenate-length > 0
STRING RXSINP-INDIVID(IXNOTBL: CONCATENATE-LENGTH) ' '
DELIMITED BY SIZE
INTO CONCATENATE-LINE
POINTER CONCATENATE-POINTER
end-if
MOVE ')NOP GEN' to WSRXSINP-INDIVID
MOVE 4 TO WSRXSINP-LGTH
ELSE
IF CONCATENATE-POINTER > 1
IF RXSINP-INDIVID(IXNOTBL:1) = ')'
IF RXSINP-INDIVID(IXNOTBL:2) NOT = ')&' AND ')+'
PERFORM FEJLMELD-NY-BLOK-I-CONTINU
END-IF
END-IF
STRING
CONCATENATE-LINE(1: CONCATENATE-POINTER - 1)
RXSINP-INDIVID(1: RXSINP-LGTH)
DELIMITED BY SIZE INTO WSRXSINP-INDIVID
COMPUTE WSRXSINP-LGTH =
CONCATENATE-POINTER - 1 + RXSINP-LGTH
MOVE 1 TO CONCATENATE-POINTER
ELSE
* fjern leading spaces og flyt resten:
COMPUTE IXX = RXSINP-LGTH - IXNOTBL + 1
MOVE RXSINP-INDIVID(IXNOTBL:IXX)
TO WSRXSINP-INDIVID
MOVE IXX TO WSRXSINP-LGTH
END-IF
END-IF
ELSE
* hvis der ikke må konkateneres:
IF WS-TEMP-LVL > 1
OR TEKST-IS-TEXT-ENDTEXT-MARK = 'J'
COMPUTE IXX = RXSINP-LGTH - IXNOTBL + 1
MOVE RXSINP-INDIVID(IXNOTBL:IXX) TO WSRXSINP-INDIVID
MOVE IXX TO WSRXSINP-LGTH
ELSE
MOVE RXSINP-INDIVID(1:RXSINP-LGTH) TO WSRXSINP-INDIVID
MOVE RXSINP-LGTH TO WSRXSINP-LGTH
END-IF
END-IF
.
CONCATENATE-CONTINUATION-EX.
EXIT.
FIND-TYPE-AF-LINIE SECTION.
* 2006-04-19 Hvis continuation er forvandlet til NOP, bruges
* linienr fra første linie i continuation i den videreførte linie:
IF WS-NOP-LINNR > SPACES
MOVE WS-NOP-LINNR TO WS-LINNR
MOVE SPACES TO WS-NOP-LINNR
END-IF
* DISPLAY WSRXSINP-INDIVID(1:WSRXSINP-LGTH)
* DISPLAY WS-STATUS-G(1:40) ' ' wsrxsinp-lgth
MOVE SPACE TO SPECIAL-ORD-SW
MOVE SPACE TO EQUALS-FUNDET-SW
MOVE FUNCTION UPPER-CASE(WSRXSINP-INDIVID(1:10)) TO LOKSTRING
EVALUATE TRUE
WHEN RXSINP-LGTH = 1
AND RXSINP-INDIVID(1:1) = SPACE
* blanke linier:
IF WS-LVL > 1 AND WS-TEXT-LEVEL(WS-LVL) NOT = WS-LVL
CONTINUE
ELSE
MOVE ' ' TO WSRXSOUTP-INDIVID
* MOVE 1 TO WSRXSOUTP-LGTH
* PERFORM SKRIV-LINIE
STRING 'RX_T=' WS-LINNR ';'
DELIMITED BY SPACE
'CALL SKRIV_UD "";'
DELIMITED BY SIZE INTO
WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
SUBTRACT 1 FROM WSRXSOUTP-LGTH
PERFORM SKRIV-LINIE
END-IF
WHEN RXSINP-LGTH = 0
* blanke linier:
IF WS-LVL > 1 AND WS-TEXT-LEVEL(WS-LVL) NOT = WS-LVL
CONTINUE
ELSE
MOVE ' ' TO WSRXSOUTP-INDIVID
* MOVE 1 TO WSRXSOUTP-LGTH
* PERFORM SKRIV-LINIE
STRING 'RX_T=' WS-LINNR ';'
DELIMITED BY SPACE
'CALL SKRIV_UD "";'
DELIMITED BY SIZE INTO
WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
SUBTRACT 1 FROM WSRXSOUTP-LGTH
PERFORM SKRIV-LINIE
END-IF
WHEN LOKSTRING(1:8) = ')ACTION '
* 22/4-03 ordrer gøres alligevel globale (pga evt. ispf-panel vars)
MOVE 9 TO WSRXSINP-STRT
PERFORM FIND-ORD-RXSINP
PERFORM CHANGE-DROPQUEUE-GLOBAL
ADD 1 TO WS-LVL
PERFORM SKRIV-LINIE-ASIS
WHEN LOKSTRING(1:6) = ')TEXT '
MOVE 7 TO WSRXSINP-STRT
PERFORM FIND-ORD-RXSINP
PERFORM CHANGE-DROPQUEUE-GLOBAL
ADD 1 TO WS-LVL
MOVE WS-LVL TO WS-TEXT-LEVEL(WS-LVL)
PERFORM SKRIV-LINIE-ASIS
WHEN LOKSTRING(1:10)= ')ENDACTION'
IF WS-LVL = WS-TEXT-LEVEL(WS-LVL)
PERFORM FEJLMELD-ENDACTION
END-IF
SUBTRACT 1 FROM WS-LVL
PERFORM SKRIV-LINIE-ASIS
PERFORM CHECK-AFSLUTNING-AF-COMMENT
WHEN LOKSTRING(1:10)= ')ENDTEXT'
IF WS-LVL NOT = WS-TEXT-LEVEL(WS-LVL)
PERFORM FEJLMELD-ENDTEXT
END-IF
MOVE 999 TO WS-TEXT-LEVEL(WS-LVL)
SUBTRACT 1 FROM WS-LVL
PERFORM SKRIV-LINIE-ASIS
WHEN LOKSTRING(1:8) = ')DEFAULT'
PERFORM SKRIV-LINIE-ASIS
WHEN LOKSTRING(1:6) = ')IMBED'
MOVE 8 TO WSRXSINP-STRT
PERFORM FIND-ORD-RXSINP
PERFORM SKRIV-LINIE-ASIS
WHEN LOKSTRING(1:8) = ')TRIGGER'
PERFORM SKRIV-LINIE-ASIS
WHEN LOKSTRING(1:10) = ')NOTRIGGER'
PERFORM SKRIV-LINIE-ASIS
WHEN LOKSTRING(1:4) = ')NOP'
PERFORM SKRIV-LINIE-ASIS
WHEN LOKSTRING(1:3) = ')& '
MOVE 4 TO WSRXSINP-STRT
PERFORM FIND-ORD-RXSINP
PERFORM SKRIV-LINIE-ASIS
WHEN LOKSTRING(1:3) = ')+ '
MOVE 4 TO WSRXSINP-STRT
PERFORM FIND-ORD-RXSINP
PERFORM SKRIV-LINIE-ASIS
WHEN LOKSTRING(1:10) = ')INTERFACE'
PERFORM SKRIV-LINIE-ASIS
IF LOKSTRING(1:8) = ')NOP GEN'
IF WS-NOP-LINNR = SPACES
MOVE WS-LINNR TO WS-NOP-LINNR
END-IF
END-IF
WHEN LOKSTRING(1:1) = ')'
AND LOKSTRING(2:1) > ' '
AND LOKSTRING(3:1) > ' '
PERFORM SKRIV-UKENDT-RXS-DELIMITER
WHEN WS-LVL > 1 AND WS-TEXT-LEVEL(WS-LVL) NOT = WS-LVL
* aktiv-kode med uden linienr
MOVE ' ' TO RX-SW-INPUT-DATA
MOVE 1 TO WSRXSINP-STRT
PERFORM FIND-ORD-RXSINP
EVALUATE TRUE
WHEN WS-STATUS-G(1:1) = 'r'
WHEN WS-STATUS-G(1:2) = 'Cr'
WHEN WS-STATUS-G(1:3) = 'CBr'
WHEN WS-STATUS-G(1:2) = 'Br'
WHEN WS-STATUS-G(1:3) = 'BCr'
WHEN WS-STATUS-G(1:4) = 'BCBr'
WHEN WS-STATUS-G(1:1) = ' '
WHEN WS-STATUS-G(1:2) = 'C '
* rexx sætning uden linienr:
STRING WSRXSINP-INDIVID(1:WSRXSINP-LGTH)
';'
DELIMITED BY SIZE INTO
WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
SUBTRACT 1 FROM WSRXSOUTP-LGTH
PERFORM SKRIV-LINIE
WHEN EQUALS-FUNDET-SW = '1'
WHEN WS-STATUS-G(1:3) = 'VBO'
WHEN WS-STATUS-G(1:2) = 'VO'
WHEN WS-STATUS-G(1:3) = 'CVO'
WHEN WS-STATUS-G(1:4) = 'CBVO'
WHEN WS-STATUS-G(1:5) = 'CBVBO'
WHEN WS-STATUS-G(1:1) = 'R'
WHEN WS-STATUS-G(1:2) = 'CR'
WHEN WS-STATUS-G(1:3) = 'CBR'
WHEN WS-STATUS-G(1:4) = 'BVBO'
WHEN WS-STATUS-G(1:3) = 'BVO'
WHEN WS-STATUS-G(1:4) = 'BCVO'
WHEN WS-STATUS-G(1:5) = 'BCBVO'
WHEN WS-STATUS-G(1:6) = 'BCBVBO'
WHEN WS-STATUS-G(1:2) = 'BR'
WHEN WS-STATUS-G(1:3) = 'BCR'
WHEN WS-STATUS-G(1:4) = 'BCBR'
* rexx sætning med linienr:
EVALUATE SPECIAL-ORD-SW
WHEN 'A'
* (ADDRESS)
IF WS-STATUS(5) > SPACE
ADD 1 TO WSRXSINP-LGTH
STRING ';IF RC>11 THEN DO;'
'RX_FMESS="#Error in addressed command";'
'CALL SYNTAXFEJL;END'
DELIMITED BY SIZE INTO
WSRXSINP-INDIVID
POINTER WSRXSINP-LGTH
END-IF
WHEN 'R'
* (RETURN)
COMPUTE IXX = SPECIAL-ORD-START + 6
COMPUTE IXXX =
WSRXSINP-LGTH - SPECIAL-ORD-START - 5
MOVE 1 TO WSRXSINP-LGTH
IF SPECIAL-ORD-START > 1
SUBTRACT 1 FROM SPECIAL-ORD-START
STRING WSRXSINP-INDIVID(1:SPECIAL-ORD-START)
DELIMITED BY SIZE INTO
WSTEMP-INDIVID
POINTER WSRXSINP-LGTH
END-IF
STRING ' CALL USER_RETURN '
DELIMITED BY SIZE INTO
WSTEMP-INDIVID
POINTER WSRXSINP-LGTH
IF IXXX > 0
STRING WSRXSINP-INDIVID(IXX: IXXX)
DELIMITED BY SIZE INTO
WSTEMP-INDIVID
POINTER WSRXSINP-LGTH
END-IF
SUBTRACT 1 FROM WSRXSINP-LGTH
MOVE WSTEMP-INDIVID(1:WSRXSINP-LGTH) TO
WSRXSINP-INDIVID(1:WSRXSINP-LGTH)
WHEN 'E'
* (EXIT)
COMPUTE IXX = SPECIAL-ORD-START + 4
COMPUTE IXXX =
WSRXSINP-LGTH - SPECIAL-ORD-START - 3
MOVE 1 TO WSRXSINP-LGTH
IF SPECIAL-ORD-START > 1
SUBTRACT 1 FROM SPECIAL-ORD-START
STRING WSRXSINP-INDIVID(1:SPECIAL-ORD-START)
DELIMITED BY SIZE INTO
WSTEMP-INDIVID
POINTER WSRXSINP-LGTH
END-IF
STRING ' CALL USER_EXIT '
DELIMITED BY SIZE INTO
WSTEMP-INDIVID
POINTER WSRXSINP-LGTH
IF IXXX > 0
STRING WSRXSINP-INDIVID(IXX: IXXX)
DELIMITED BY SIZE INTO
WSTEMP-INDIVID
POINTER WSRXSINP-LGTH
END-IF
SUBTRACT 1 FROM WSRXSINP-LGTH
MOVE WSTEMP-INDIVID(1:WSRXSINP-LGTH) TO
WSRXSINP-INDIVID(1:WSRXSINP-LGTH)
WHEN 'T'
* (THEN) (dvs sætning indeholder ordet 'THEN' et sted)
MOVE ZERO TO WXX
PERFORM VARYING WX FROM 1 BY 1
UNTIL WX > WSRXSINP-LGTH - 10
IF FUNCTION UPPER-CASE (
WSRXSINP-INDIVID(WX:10)) = ' DROPQUEUE'
MOVE WX TO WXX
END-IF
END-PERFORM
IF WXX = 0
PERFORM VARYING WX FROM 1 BY 1
UNTIL WX > WSRXSINP-LGTH - 8
IF FUNCTION UPPER-CASE (
WSRXSINP-INDIVID(WX:9)) = ' SET_HALT'
MOVE WX TO WXX
END-IF
END-PERFORM
END-IF
IF WXX = 0
PERFORM VARYING WX FROM 1 BY 1
UNTIL WX > WSRXSINP-LGTH - 7
IF FUNCTION UPPER-CASE (
WSRXSINP-INDIVID(WX:12)) = ' SET_MESSAGE'
MOVE WX TO WXX
END-IF
END-PERFORM
END-IF
EVALUATE TRUE
WHEN WXX > 0
* (dvs der står DROPQUEUE eller SET_HALT eller SET_MESSAGE efter THEN...)
COMPUTE IXX = SPECIAL-ORD-START + 4
COMPUTE IXXX =
WSRXSINP-LGTH - SPECIAL-ORD-START - 3
MOVE 1 TO WSRXSINP-LGTH
STRING
WSRXSINP-INDIVID(1:IXX)
' CALL '
WSRXSINP-INDIVID(IXX:IXXX)
DELIMITED BY SIZE INTO
WSTEMP-INDIVID
POINTER WSRXSINP-LGTH
SUBTRACT 1 FROM WSRXSINP-LGTH
MOVE WSTEMP-INDIVID(1:WSRXSINP-LGTH) TO
WSRXSINP-INDIVID(1:WSRXSINP-LGTH)
WHEN WS-STATUS(SPECIAL-ORD-NUMMER + 2)
= 'F' OR 'Q' OR 'N'
* (dvs udtrykket efter THEN addresseres til environment)
COMPUTE IXX = SPECIAL-ORD-START + 4
COMPUTE IXXX =
WSRXSINP-LGTH - SPECIAL-ORD-START - 3
MOVE 1 TO WSRXSINP-LGTH
STRING
WSRXSINP-INDIVID(1:IXX)
' CALL SKRIV_UD '
WSRXSINP-INDIVID(IXX:IXXX)
DELIMITED BY SIZE INTO
WSTEMP-INDIVID
POINTER WSRXSINP-LGTH
SUBTRACT 1 FROM WSRXSINP-LGTH
MOVE WSTEMP-INDIVID(1:WSRXSINP-LGTH) TO
WSRXSINP-INDIVID(1:WSRXSINP-LGTH)
END-EVALUATE
END-EVALUATE
STRING 'RX_T=' WS-LINNR ';'
DELIMITED BY SPACE
WSRXSINP-INDIVID(1:WSRXSINP-LGTH)
';'
DELIMITED BY SIZE INTO
WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
SUBTRACT 1 FROM WSRXSOUTP-LGTH
PERFORM SKRIV-LINIE
* 2005-06-06: dropqueue accepteres som 'instruktion' dvs uden call:
WHEN FUNCTION UPPER-CASE(WSRXSINP-INDIVID(1:9))
= 'DROPQUEUE'
STRING 'RX_T=' WS-LINNR ';'
DELIMITED BY SPACE
'CALL '
WSRXSINP-INDIVID(1:WSRXSINP-LGTH)
';'
DELIMITED BY SIZE INTO
WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
SUBTRACT 1 FROM WSRXSOUTP-LGTH
PERFORM SKRIV-LINIE
* 2013-10-18: SET_HALT accepteres som 'instruktion' dvs uden call:
WHEN FUNCTION UPPER-CASE(WSRXSINP-INDIVID(1:8))
= 'SET_HALT'
STRING 'RX_T=' WS-LINNR ';'
DELIMITED BY SPACE
'CALL '
WSRXSINP-INDIVID(1:WSRXSINP-LGTH)
';'
DELIMITED BY SIZE INTO
WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
SUBTRACT 1 FROM WSRXSOUTP-LGTH
PERFORM SKRIV-LINIE
* 2013-10-18: SET_MESSAGE accepteres som 'instruktion' dvs uden call:
WHEN FUNCTION UPPER-CASE(WSRXSINP-INDIVID(1:11))
= 'SET_MESSAGE'
STRING 'RX_T=' WS-LINNR ';'
DELIMITED BY SPACE
'CALL '
WSRXSINP-INDIVID(1:WSRXSINP-LGTH)
';'
DELIMITED BY SIZE INTO
WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
SUBTRACT 1 FROM WSRXSOUTP-LGTH
PERFORM SKRIV-LINIE
* 2005-06-06: make_global accepteres som 'instruktion' dvs uden call:
WHEN FUNCTION UPPER-CASE(WSRXSINP-INDIVID(1:11))
= 'MAKE_GLOBAL'
STRING 'RX_T=' WS-LINNR ';'
DELIMITED BY SPACE
'CALL '
WSRXSINP-INDIVID(1:WSRXSINP-LGTH)
';'
DELIMITED BY SIZE INTO
WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
SUBTRACT 1 FROM WSRXSOUTP-LGTH
PERFORM SKRIV-LINIE
WHEN ANY
STRING 'RX_T=' WS-LINNR ';'
DELIMITED BY SPACE
'CALL SKRIV_UD '
WSRXSINP-INDIVID(1:WSRXSINP-LGTH)
';'
DELIMITED BY SIZE INTO
WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
SUBTRACT 1 FROM WSRXSOUTP-LGTH
PERFORM SKRIV-LINIE
END-EVALUATE
WHEN ANY
* ufortolket input
MOVE '1' TO RX-SW-INPUT-DATA
STRING 'RX_T=' WS-LINNR
DELIMITED BY SPACE
';CALL SKRIV_UD_DIR;'
DELIMITED BY SIZE INTO
WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
SUBTRACT 1 FROM WSRXSOUTP-LGTH
PERFORM SKRIV-LINIE
END-EVALUATE
.
FIND-TYPE-AF-LINIE-EX.
EXIT.
FIND-ORD-RXSINP SECTION.
* resultat:
* WS-STATUS(x) viser type af x'te element i linien (fx V)
* WS-POINTER(x) viser startbyte af x'te element i linien
* længden af elementet er frem til WS-POINTER(x+1) - 1
* (dvs WS-PONTER(1) er altid 1)
MOVE LOW-VALUES TO WS-POINTER-G
MOVE SPACES TO WS-STATUS-G
MOVE SPACE TO QUOTESW
MOVE 1 TO IFORR
PERFORM VARYING IX FROM WSRXSINP-STRT BY 1
UNTIL IX > WSRXSINP-LGTH
PERFORM FIND-ORD-RXSINP-II
END-PERFORM
* Hvis ubalance i først nævnte quote på linien (dvs hvis den ikke
* er afsluttet på samme linie):
IF QUOTESW NOT = ' '
PERFORM FEJLMELD-QUOTE-EJ-BALANCE
END-IF
* blank kommentarer ud:
PERFORM VARYING IX FROM WSRXSINP-STRT BY 1
UNTIL IX > WSRXSINP-LGTH
IF IN-STATU(IX) = 'C'
MOVE SPACE TO WSRXSINP-CHAR(IX)
END-IF
* varibelnavne kan indeholde numeriske tegn:
IF IX > 1
IF IN-STATU(IX) = 'N'
AND IN-STATU(IX - 1) = 'V'
MOVE 'V' TO IN-STATU(IX)
END-IF
END-IF
END-PERFORM
MOVE 1 TO IFORR
MOVE 1 TO WS-POINTER(1)
MOVE 1 TO IXIX
MOVE IN-STATU(1) TO WS-STATUS(IXIX)
PERFORM VARYING IX FROM WSRXSINP-STRT BY 1
UNTIL IX > WSRXSINP-LGTH
PERFORM FIND-ORD-RXSINP-III
END-PERFORM
IF WSRXSINP-LGTH > 0
ADD 1 TO IXIX
COMPUTE WS-POINTER(IXIX) = WSRXSINP-LGTH + 1
* DISPLAY WSRXSINP-INDIVID(1:WSRXSINP-LGTH)
* DISPLAY IN-STATU-G(1:WSRXSINP-LGTH)
MOVE WS-POINTER(1) TO IXFORR
PERFORM VARYING IX FROM 2 BY 1 UNTIL IX > IXIX
* flyttet hertil 2010-03-13:
COMPUTE IXLGTH = WS-POINTER(IX) - IXFORR
IF WSRXSINP-INDIVID(IXFORR: IXLGTH) NUMERIC
MOVE 'N' TO WS-STATUS(IX - 1)
END-IF
* flyt COMPUTE IXLGTH = WS-POINTER(IX) - IXFORR
EVALUATE
FUNCTION UPPER-CASE(WSRXSINP-INDIVID(IXFORR: IXLGTH))
WHEN 'END'
WHEN 'SELECT'
WHEN 'ELSE'
WHEN 'WHEN'
WHEN 'OTHERWISE'
WHEN 'DO'
WHEN 'ITERATE'
WHEN 'LEAVE'
MOVE 'r' TO WS-STATUS(IX - 1)
WHEN 'THEN'
MOVE 'r' TO WS-STATUS(IX - 1)
MOVE 'T' TO SPECIAL-ORD-SW
MOVE IXFORR TO SPECIAL-ORD-START
COMPUTE SPECIAL-ORD-NUMMER = IX - 1
WHEN 'ADDRESS'
MOVE 'R' TO WS-STATUS(IX - 1)
MOVE 'A' TO SPECIAL-ORD-SW
MOVE IXFORR TO SPECIAL-ORD-START
WHEN 'EXIT'
MOVE 'R' TO WS-STATUS(IX - 1)
MOVE 'E' TO SPECIAL-ORD-SW
MOVE IXFORR TO SPECIAL-ORD-START
WHEN 'RETURN'
MOVE 'R' TO WS-STATUS(IX - 1)
MOVE 'R' TO SPECIAL-ORD-SW
MOVE IXFORR TO SPECIAL-ORD-START
WHEN 'IF'
WHEN 'SAY'
WHEN 'CALL'
WHEN 'DROP'
WHEN 'TRACE'
WHEN 'INTERPRET'
WHEN 'NOP'
WHEN 'NUMERIC'
WHEN 'PULL'
WHEN 'PUSH'
WHEN 'PARSE'
WHEN 'OPTIONS'
WHEN 'QUEUE'
WHEN 'UPPER'
WHEN 'SIGNAL'
WHEN 'VALUE'
WHEN 'WITH'
WHEN 'FOREVER'
MOVE 'R' TO WS-STATUS(IX - 1)
END-EVALUATE
* vis resultat:
* DISPLAY 'WS-POINTER: ' WS-POINTER(IX)
* DISPLAY WS-STATUS(IX - 1)
* ' |' WSRXSINP-INDIVID(IXFORR: IXLGTH) '|'
* vis resultat slut
IF SPECIAL-ORD-SW NOT = 'A'
* (ordet ADDRESS stopper jagten på brugervariable..)
MOVE WSRXSINP-INDIVID(IXFORR: IXLGTH) TO WS-USERVAR
MOVE WSRXSINP-INDIVID(IXFORR + IXLGTH: 1)
TO WS-NEXTCHAR
MOVE FUNCTION UPPER-CASE(WS-USERVAR) TO WS-USERVAR
MOVE WS-POINTER(IX) TO IXFORR
IF WS-STATUS(IX - 1) = 'V'
EVALUATE WS-USERVAR
WHEN 'IN'
WHEN 'INFILE'
WHEN 'INSQL'
WHEN 'OUT'
WHEN 'OUTFILE'
WHEN 'FUNC'
WHEN 'CONT'
WHEN 'WORD'
WHEN 'UNIT'
WHEN 'OUTFUNC'
WHEN 'RXSPARM'
WHEN 'SQLLIMIT'
WHEN 'SQL'
WHEN 'SQLNAMES'
WHEN 'SQLNULLS'
WHEN 'SQLVALUES'
WHEN 'SQLTYPES'
WHEN 'PROMPT'
WHEN 'PROMPTLGTH'
WHEN 'PROMPTSOURCE'
WHEN 'PROMPTALL'
WHEN 'CAPS'
WHEN 'RXINMEMB'
WHEN 'RXENDTXT'
WHEN 'MBR'
WHEN 'IMBED'
WHEN 'MQ'
WHEN 'MQ_BACKOUT'
WHEN 'MQ_MESSID'
WHEN 'DROPQUEUE'
WHEN 'MAKE_GLOBAL'
WHEN 'ZWINTTL'
WHEN 'NAMESPACE_1'
WHEN 'NAMESPACE_2'
CONTINUE
WHEN ANY
IF WS-NEXTCHAR = '.'
MOVE SPACE TO WS-USERVAR2
* (stems skal gøres globale incl punktum)
STRING WS-USERVAR '.'
DELIMITED BY SPACE INTO WS-USERVAR2
MOVE WS-USERVAR2 TO WS-USERVAR
END-IF
IF WS-USERVAR(1:3) = 'RX_'
PERFORM FEJLMELD-VARNAVN
END-IF
IF WS-USERVAR = 'RESULT'
PERFORM FEJLMELD-VARNAVN
END-IF
SET EXPIDX TO 1
SEARCH WS-EXPLIST-ELM
AT END
IF WS-EXPLIST-ANT = 500
PERFORM FEJLMELD-ANT-EXPLIST
ELSE
ADD 1 TO WS-EXPLIST-ANT
MOVE WS-USERVAR TO
WS-EXPLIST-ELM(WS-EXPLIST-ANT)
END-IF
WHEN WS-USERVAR = WS-EXPLIST-ELM(EXPIDX)
CONTINUE
END-SEARCH
END-EVALUATE
END-IF
END-IF
END-PERFORM
* DISPLAY
* WS-POINTER(1) ' '
* WS-POINTER(2) ' '
* WS-POINTER(3) ' '
* WS-POINTER(4) ' '
* WS-POINTER(5) ' '
* WS-POINTER(6) ' '
* WS-POINTER(7) ' '
* WS-POINTER(8) ' '
* WS-POINTER(9) ' '
* WS-POINTER(10) ' '
* DISPLAY WS-STATUS-G(1:10)
* ELSE
* DISPLAY '*** NULL LINIE'
END-IF
* DISPLAY '----------------------------------------'
* Klar til behandl næste linie:
MOVE SPACES TO IN-STATU-G(1:WSRXSINP-LGTH)
.
FIND-ORD-RXSINP-EX.
EXIT.
FIND-ORD-RXSINP-II SECTION.
* gennemløb bogstav for bogstav:
EVALUATE TRUE
* Fjern qouted:
WHEN WSRXSINP-CHAR(IX) = '"' AND QUOTESW = ' '
AND COMMSW = ' '
MOVE 'Q' TO IN-STATU(IX)
MOVE 'D' TO QUOTESW
WHEN WSRXSINP-CHAR(IX) = '"' AND QUOTESW = 'D'
AND COMMSW = ' '
MOVE 'Q' TO IN-STATU(IX)
MOVE ' ' TO QUOTESW
WHEN WSRXSINP-CHAR(IX) = "'" AND QUOTESW = ' '
AND COMMSW = ' '
MOVE 'Q' TO IN-STATU(IX)
MOVE 'S' TO QUOTESW
WHEN WSRXSINP-CHAR(IX) = "'" AND QUOTESW = 'S'
AND COMMSW = ' '
MOVE 'Q' TO IN-STATU(IX)
MOVE ' ' TO QUOTESW
WHEN QUOTESW NOT = ' '
AND COMMSW = ' '
MOVE 'Q' TO IN-STATU(IX)
* Fjern comment:
WHEN WSRXSINP-CHAR(IX) = '*' AND WSRXSINP-CHAR(IFORR) = '/'
MOVE 'C' TO IN-STATU(IX)
MOVE 'C' TO IN-STATU(IFORR)
MOVE '1' TO COMMSW
MOVE WS-LINNR TO WS-GEM-COMMENT-START
WHEN WSRXSINP-CHAR(IX) = '/' AND WSRXSINP-CHAR(IFORR) = '*'
MOVE 'C' TO IN-STATU(IX)
MOVE 'C' TO IN-STATU(IFORR)
MOVE ' ' TO COMMSW
WHEN COMMSW = '1'
MOVE 'C' TO IN-STATU(IX)
* Fjern funktionskald:
WHEN WSRXSINP-CHAR(IX) = '('
AND WSRXSINP-CHAR(IFORR) NOT = ' '
MOVE 'F' TO IN-STATU(IX)
PERFORM VARYING IXLOK FROM IFORR BY -1 UNTIL IXLOK < 1
IF WSRXSINP-CHAR(IXLOK) NOT = ' '
AND WSRXSINP-CHAR(IXLOK) NOT SPEC-CHAR
MOVE 'F' TO IN-STATU(IXLOK)
ELSE
MOVE 0 TO IXLOK
END-IF
END-PERFORM
WHEN WSRXSINP-CHAR(IX) = ' '
MOVE 'B' TO IN-STATU(IX)
WHEN WSRXSINP-CHAR(IX) = '='
MOVE 'O' TO IN-STATU(IX)
MOVE '1' TO EQUALS-FUNDET-SW
WHEN WSRXSINP-CHAR(IX) IS OPERA-CHAR
MOVE 'O' TO IN-STATU(IX)
WHEN WSRXSINP-CHAR(IX) IS SPEC-CHAR
MOVE 'S' TO IN-STATU(IX)
WHEN WSRXSINP-CHAR(IX) IS NUMERIC
MOVE 'N' TO IN-STATU(IX)
WHEN ANY
MOVE 'V' TO IN-STATU(IX)
END-EVALUATE
MOVE IX TO IFORR
.
FIND-ORD-RXSINP-II-EX.
EXIT.
FIND-ORD-RXSINP-III SECTION.
IF IN-STATU(IX) NOT = IN-STATU(IFORR)
* AND NOT (IN-STATU(IX) ='N' AND IN-STATU(IFORR) = 'V')
* (variabelnavne kan ende på numeriske tegn)
ADD 1 TO IXIX
MOVE IX TO WS-POINTER(IXIX)
MOVE IN-STATU(IX) TO WS-STATUS(IXIX)
END-IF
MOVE IX TO IFORR
.
FIND-ORD-RXSINP-III-EX.
EXIT.
DAN-EXPLIST SECTION.
MOVE 1 TO WS-RES-EXPLIST-PTR
STRING ')EXP '
DELIMITED BY SIZE
INTO WS-RES-EXPLIST
POINTER WS-RES-EXPLIST-PTR
PERFORM VARYING Z1 FROM 1 BY 1 UNTIL Z1 >
WS-EXPLIST-ANT
STRING WS-EXPLIST-ELM(Z1)
DELIMITED BY SPACE
INTO WS-RES-EXPLIST
POINTER WS-RES-EXPLIST-PTR
STRING ' '
DELIMITED BY SIZE
INTO WS-RES-EXPLIST
POINTER WS-RES-EXPLIST-PTR
END-PERFORM
SUBTRACT 1 FROM WS-RES-EXPLIST-PTR
MOVE WS-RES-EXPLIST-PTR TO RXSOUTP-LGTH
WSRXSOUTP-LGTH
MOVE WS-RES-EXPLIST(1: WS-RES-EXPLIST-PTR)
TO RXSOUTP-INDIVID
WRITE RXSOUTP-INDIVID
* DISPLAY 'HER ER EXPLIST: '
* WS-RES-EXPLIST(1: WS-RES-EXPLIST-PTR - 1) '||'
.
DAN-EXPLIST-EX.
EXIT.
SKRIV-LINIE SECTION.
MOVE WSRXSOUTP-LGTH TO RXSOUTP-LGTH
MOVE WSRXSOUTP-INDIVID(1:WSRXSOUTP-LGTH)
TO RXSOUTP-INDIVID
WRITE RXSOUTP-INDIVID
.
SKRIV-LINIE-EX.
EXIT.
SKRIV-LINIE-ASIS SECTION.
MOVE WSRXSINP-LGTH TO RXSOUTP-LGTH
WSRXSOUTP-LGTH
MOVE WSRXSINP-INDIVID(1:WSRXSINP-LGTH)
TO RXSOUTP-INDIVID
WRITE RXSOUTP-INDIVID
.
SKRIV-LINIE-ASIS-EX.
EXIT.
FEJLMELD-VARNAVN SECTION.
MOVE 1 TO WSRXSOUTP-LGTH
MOVE '1' TO GROV-FEJL-FUNDET
STRING
')ERR '
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
STRING
WS-LINNR
DELIMITED BY SPACE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
STRING
' Variable-name '
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
STRING
WS-USERVAR
DELIMITED BY SPACE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
STRING
' is no good. Use another name'
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
SUBTRACT 1 FROM WSRXSOUTP-LGTH
MOVE WSRXSOUTP-INDIVID(1:WSRXSOUTP-LGTH)
TO RXSOUTP-INDIVID
MOVE WSRXSOUTP-LGTH TO RXSOUTP-LGTH
WRITE RXSOUTP-INDIVID
MOVE 1 TO WSRXSOUTP-LGTH
.
FEJLMELD-VARNAVN-EX.
EXIT.
SKRIV-UKENDT-RXS-DELIMITER SECTION.
MOVE 1 TO WSRXSOUTP-LGTH
EVALUATE TRUE
* gammel RXS syntax - hop til denne:
WHEN LOKSTRING(1:5) = ')RXS '
WHEN LOKSTRING(1:8) = ')ENDRXS '
WHEN LOKSTRING(1:6) = ')SCAN '
WHEN LOKSTRING(1:9) = ')ENDSCAN '
WHEN LOKSTRING(1:8) = ')PROMPT '
WHEN LOKSTRING(1:8) = ')INLINE '
STRING
')ERR *RXS1*'
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
WHEN ANY
MOVE '1' TO GROV-FEJL-FUNDET
STRING
')ERR '
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
STRING
WS-LINNR
DELIMITED BY SPACE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
STRING
' Unknown RXS block-delimiter: '
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
STRING
WSRXSINP-INDIVID(1:WSRXSINP-LGTH)
DELIMITED BY SPACE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
END-EVALUATE
SUBTRACT 1 FROM WSRXSOUTP-LGTH
MOVE WSRXSOUTP-INDIVID(1:WSRXSOUTP-LGTH)
TO RXSOUTP-INDIVID
MOVE WSRXSOUTP-LGTH TO RXSOUTP-LGTH
WRITE RXSOUTP-INDIVID
MOVE 1 TO WSRXSOUTP-LGTH
.
SKRIV-UKENDT-RXS-DELIMIT-EX.
EXIT.
FEJLMELD-ENDTEXT SECTION.
MOVE 1 TO WSRXSOUTP-LGTH
MOVE '1' TO GROV-FEJL-FUNDET
STRING
')ERR '
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
STRING
WS-LINNR
DELIMITED BY SPACE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
STRING
' )ENDTEXT mis-placed in context - no )TEXT at this level'
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
SUBTRACT 1 FROM WSRXSOUTP-LGTH
MOVE WSRXSOUTP-INDIVID(1:WSRXSOUTP-LGTH)
TO RXSOUTP-INDIVID
MOVE WSRXSOUTP-LGTH TO RXSOUTP-LGTH
WRITE RXSOUTP-INDIVID
MOVE 1 TO WSRXSOUTP-LGTH
.
FEJLMELD-ENDTEXT-EX.
EXIT.
FEJLMELD-ENDACTION SECTION.
MOVE 1 TO WSRXSOUTP-LGTH
MOVE '1' TO GROV-FEJL-FUNDET
STRING
')ERR '
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
STRING
WS-LINNR
DELIMITED BY SPACE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
STRING
' )ENDACTION mis-placed in context - )TEXT is in effect'
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
SUBTRACT 1 FROM WSRXSOUTP-LGTH
MOVE WSRXSOUTP-INDIVID(1:WSRXSOUTP-LGTH)
TO RXSOUTP-INDIVID
MOVE WSRXSOUTP-LGTH TO RXSOUTP-LGTH
WRITE RXSOUTP-INDIVID
MOVE 1 TO WSRXSOUTP-LGTH
.
FEJLMELD-ENDACTION-EX.
EXIT.
FEJLMELD-ANT-EXPLIST SECTION.
MOVE 1 TO WSRXSOUTP-LGTH
STRING
')ERR '
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
STRING
WS-LINNR
DELIMITED BY SPACE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
STRING
' More than 500 variables detected in this RXS program'
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
SUBTRACT 1 FROM WSRXSOUTP-LGTH
MOVE WSRXSOUTP-INDIVID(1:WSRXSOUTP-LGTH)
TO RXSOUTP-INDIVID
MOVE WSRXSOUTP-LGTH TO RXSOUTP-LGTH
WRITE RXSOUTP-INDIVID
MOVE 1 TO WSRXSOUTP-LGTH
.
FEJLMELD-ANTAL-EXPLIST-EX.
EXIT.
FEJLMELD-QUOTE-EJ-BALANCE SECTION.
MOVE 1 TO WSRXSOUTP-LGTH
MOVE '1' TO GROV-FEJL-FUNDET
STRING
')ERR '
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
STRING
WS-LINNR
DELIMITED BY SPACE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
IF QUOTESW = 'S'
STRING
' Line contains uneven number of single quotes'
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
ELSE
STRING
' Line contains uneven number of double quotes'
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
END-IF
SUBTRACT 1 FROM WSRXSOUTP-LGTH
MOVE WSRXSOUTP-INDIVID(1:WSRXSOUTP-LGTH)
TO RXSOUTP-INDIVID
MOVE WSRXSOUTP-LGTH TO RXSOUTP-LGTH
WRITE RXSOUTP-INDIVID
MOVE 1 TO WSRXSOUTP-LGTH
.
FEJLMELD-QOUTE-EJ-B-EX.
EXIT.
CHECK-AFSLUTNING-AF-BLOKKE SECTION.
IF WS-LVL > 1
MOVE '1' TO GROV-FEJL-FUNDET
MOVE 1 TO WSRXSOUTP-LGTH
STRING
')ERR '
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
STRING
WS-LINNR
DELIMITED BY SPACE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
IF WS-TEXT-LEVEL(WS-LVL) > 0
AND WS-TEXT-LEVEL(WS-LVL) < 101
STRING
' Missing )ENDTEXT - )TEXT block is not terminated'
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
ELSE
STRING
' Missing )ENDACTION - )ACTION block is not terminated'
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
END-IF
SUBTRACT 1 FROM WSRXSOUTP-LGTH
MOVE WSRXSOUTP-INDIVID(1:WSRXSOUTP-LGTH)
TO RXSOUTP-INDIVID
MOVE WSRXSOUTP-LGTH TO RXSOUTP-LGTH
WRITE RXSOUTP-INDIVID
MOVE 1 TO WSRXSOUTP-LGTH
END-IF
.
CHECK-AFSLUTNING-AF-BLOKKE-EX.
EXIT.
CHECK-AFSLUTNING-AF-COMMENT SECTION.
IF COMMSW NOT = SPACE
MOVE 1 TO WSRXSOUTP-LGTH
MOVE '1' TO GROV-FEJL-FUNDET
STRING
')ERR '
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
STRING
WS-GEM-COMMENT-START
DELIMITED BY SPACE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
STRING
' This comment-block is never terminated'
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
SUBTRACT 1 FROM WSRXSOUTP-LGTH
MOVE WSRXSOUTP-INDIVID(1:WSRXSOUTP-LGTH)
TO RXSOUTP-INDIVID
MOVE WSRXSOUTP-LGTH TO RXSOUTP-LGTH
WRITE RXSOUTP-INDIVID
MOVE 1 TO WSRXSOUTP-LGTH
END-IF
.
CHECK-AFSLUTNING-AF-COMMENT-EX.
EXIT.
FEJLMELD-NY-BLOK-I-CONTINU SECTION.
MOVE 1 TO WSRXSOUTP-LGTH
MOVE '1' TO GROV-FEJL-FUNDET
STRING
')ERR '
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
STRING
WS-LINNR
DELIMITED BY SPACE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
STRING
' RXS-block in continuated line. Remove comma above'
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
SUBTRACT 1 FROM WSRXSOUTP-LGTH
MOVE WSRXSOUTP-INDIVID(1:WSRXSOUTP-LGTH)
TO RXSOUTP-INDIVID
MOVE WSRXSOUTP-LGTH TO RXSOUTP-LGTH
WRITE RXSOUTP-INDIVID
MOVE 1 TO WSRXSOUTP-LGTH
.
FEJLMELD-NY-BLOK-I-CONTINU-EX.
EXIT.
CHANGE-DROPQUEUE-GLOBAL SECTION.
* 2011-10-04 - er det her kodning overhovedet aktivt ?????
* DROPQUEUE og MAKE_GLOBAL som generelle ordrer ændres til
* CALL RX_Q hhv. CALL RX_GLB
MOVE 0 TO IXX
MOVE ' ' TO CALL-SW
PERFORM VARYING IX FROM 1 BY 1 UNTIL IX > 999
MOVE WS-POINTER(IX) TO IXX
COMPUTE IXXX = WS-POINTER(IX + 1) - IXX
EVALUATE TRUE
WHEN WS-POINTER(IX) = 0
MOVE 5000 TO IX
WHEN IXXX < 1
MOVE 5000 TO IX
WHEN WSRXSINP-INDIVID(IXX:IXXX) = SPACE
CONTINUE
WHEN FUNCTION UPPER-CASE(WSRXSINP-INDIVID(IXX:IXXX))
= 'CALL'
MOVE '1' TO CALL-SW
WHEN FUNCTION UPPER-CASE(WSRXSINP-INDIVID(IXX:IXXX))
= 'DROPQUEUE'
IF CALL-SW = ' '
MOVE 'CALL RX_Q' TO WSRXSINP-INDIVID(IXX:IXXX)
END-IF
WHEN FUNCTION UPPER-CASE(WSRXSINP-INDIVID(IXX:IXXX))
= 'MAKE_GLOBAL'
IF CALL-SW = ' '
MOVE 'CALL RX_GLB' TO WSRXSINP-INDIVID(IXX:IXXX)
END-IF
WHEN CALL-SW = '1'
MOVE ' ' TO CALL-SW
END-EVALUATE
END-PERFORM
.
CHANGE-DROPQUEUE-GLOBAL-EX.
EXIT.
END PROGRAM RXSPGM.
* -----RXSXML---------------------------------------------
IDENTIFICATION DIVISION.
PROGRAM-ID. RXSXML.
* OPRETTET DEN 19/02-04 AF I2287
*
* Omform RXS XML input til namespace-struktur
*
* SDBSTEST.SLUTSTND.LIBRA
*
* NB: COBOL-370/390/ENTERPRISE
*
* DANNER:
* xml. hierakiet af elementer
* xml_cnt antal i xml.
* xml.0 do
* xml_elem_unch højeste nummer på element som er uændret
* siden sidst
* xml_attrib. liste over attribut-navne
* xml_attrib.0 Antal aktive attribut-navne
* xml_attrib_cnt do
* + værdier for attributter
*
* Værdier for attributter vil være null ved næste gennemløb
*
* 2004-12-15: Der bruges { og } i namespace formatet
* 2005-06-03: Attributter leveres nu samlet jvf ovenfor
* 2006-04-19: Attributter leveres også hvis element ikke har value
DATA DIVISION.
WORKING-STORAGE SECTION.
01 LIBRATID PIC X(24) LIBRATID
VALUE 'LIBRATIDLIBRATIDLIBRATID'. LIBRATID
01 FILLER REDEFINES LIBRATID. LIBRATID
02 LT-PGMID-DTO-VERSION. LIBRATID
03 LT-PGMID PIC X(8). LIBRATID
03 LT-DTO-VERSION. LIBRATID
04 LT-DTO PIC X(6). LIBRATID
04 LT-VERSION PIC X(2). LIBRATID
02 LT-TID PIC X(8). LIBRATID
01 WSRXSINP-INDIVID.
02 WSRXSINP-CHAR PIC X OCCURS 8000.
01 WSRXSOUTP-INDIVID.
02 WSRXSOUTP-CHAR PIC X OCCURS 8000.
01 EOF-SW PIC X.
01 IX PIC S9(8) COMP.
01 IX1 PIC S9(8) COMP.
01 IX2 PIC S9(8) COMP.
01 IX3 PIC S9(8) COMP.
01 WS-IND-PTR PIC S9(8) COMP.
01 XML-UD-PTR PIC S9(8) COMP.
01 WS-TALLY PIC S9(8) COMP.
01 WSX-TALLY PIC S9(8) COMP.
01 CHAR-COUNT PIC S9(8) COMP.
01 XML-DOCUMENT-LENGTH PIC S9(9) COMP.
01 RXS-HAR-CONCAT-XML-INPUT PIC X.
01 WS-9999 PIC ---9.
01 DISPLAY-XML-CODE PIC ---9.
01 DISPLAY-XML-LGTH PIC ----9.
01 WS-XML-LGTH PIC S9(8) COMP.
01 WS-XML-LEVEL PIC S9(8) COMP.
01 WS-XML-ATTRIB-LEVEL PIC S9(8) COMP.
*01 ** WS-XML-ATTR PIC X(500).
01 WS-XML-ATTR-LGTH PIC S9(8) COMP VALUE +0.
01 WS-XML-LEVEL-UNCHANGED PIC S9(8) COMP VALUE ZERO.
01 WS-ELEM-CNT PIC S9(8) COMP VALUE ZERO.
01 XML-FEJLTEKST PIC X(200).
01 FEJLUDTX-CODE PIC S9(8) COMP.
01 READY-FOR-OUTPUT-SW PIC X VALUE SPACE.
01 WS-XML-TEXT-LGTH PIC S9(8) COMP.
01 SKRIV-BLOK-PTR PIC S9(8) COMP.
01 SKRIV-BLOK-IX-G.
03 SKRIV-BLOK-IX PIC S9(8) COMP OCCURS 100.
01 BLOK-START PIC S9(8) COMP.
01 WS-POINTER-1 POINTER.
01 WS-POINTER-2 POINTER.
01 WS-POINTER-3 POINTER.
01 WS-POINTER-4 POINTER.
01 WS-POINTER-5 POINTER.
01 WS-POINTER-6 POINTER.
*01 FOERSTE-LAES PIC X.
01 WS-XML-FEJLELM PIC X(25).
01 XML-IND.
02 XML-IND-CHAR PIC X OCCURS 11000.
LINKAGE SECTION.
01 LINK-PARM-G.
02 LINK-PARM-LGTH PIC S9(4) COMP.
02 LINK-PARM PIC X(31500).
01 XML-UD.
03 XML-UD-CHAR PIC X OCCURS 16000100.
01 WS-XML-ELEMENT-G.
02 FILLER OCCURS 100.
03 WS-XML-ELEMENT PIC X(1000).
03 WS-XML-ELEMENT-LGTH PIC S9(8) COMP.
01 WS-XML-ATTRIB-G.
02 FILLER OCCURS 100.
03 WS-XML-ATTRIB PIC X(1000).
03 WS-XML-ATTRIB-LGTH PIC S9(8) COMP.
01 WS-XML-ATTRIB-VALUE-G.
02 FILLER OCCURS 100.
03 WS-XML-ATTRIB-VALUE PIC X(1000).
03 WS-XML-ATTRIB-VALUE-LGTH PIC S9(8) COMP.
01 WS-XML-TEXT-G.
02 WS-XML-TEXT PIC X(500000).
02 WS-TEMP-XML-TEXT PIC X(500000).
PROCEDURE DIVISION.
* USING LINK-PARM-G.
CALL 'RXSGEM' USING WS-POINTER-1
WS-POINTER-2
WS-POINTER-3
WS-POINTER-4
WS-POINTER-5
WS-POINTER-6
SET ADDRESS OF XML-UD TO WS-POINTER-2
SET ADDRESS OF WS-XML-ELEMENT-G TO WS-POINTER-3
SET ADDRESS OF WS-XML-ATTRIB-G TO WS-POINTER-4
SET ADDRESS OF WS-XML-ATTRIB-VALUE-G TO WS-POINTER-5
SET ADDRESS OF WS-XML-TEXT-G TO WS-POINTER-6
OPEN INPUT RXSINP
OPEN OUTPUT RXSOUTP
MOVE ' ' TO EOF-SW
MOVE 1 TO XML-UD-PTR
MOVE ' ' TO RXS-HAR-CONCAT-XML-INPUT
* MOVE '1' TO FOERSTE-LAES
PERFORM LAES-INPUT
* MOVE ' ' TO FOERSTE-LAES
MOVE 0 TO WS-XML-LEVEL
MOVE 0 TO WS-XML-LEVEL-UNCHANGED
MOVE 0 TO WS-XML-ATTRIB-LEVEL
MOVE SPACES TO WS-XML-FEJLELM
XML PARSE XML-IND(1:WS-IND-PTR)
PROCESSING PROCEDURE XML-HANDLER
ON EXCEPTION
PERFORM XML-EXCEPTION
END-XML
IF READY-FOR-OUTPUT-SW = '1'
PERFORM SKRIV
END-IF
CLOSE RXSINP
CLOSE RXSOUTP
MOVE ZERO TO RETURN-CODE
.
GOBACK.
XML-HANDLER SECTION.
EVALUATE XML-EVENT
WHEN 'START-OF-ELEMENT'
IF READY-FOR-OUTPUT-SW = '1'
* AND WS-XML-ATTRIB-LEVEL > 0 2006-10-06:
* (osse hvis der ikke er attribut, skal evt opsamlet indhold skrives)
* (hvis attributter fundet, og forrige element ikke afsluttet)
PERFORM DAN-UDDATA
MOVE ' ' TO READY-FOR-OUTPUT-SW
END-IF
ADD 1 TO WS-XML-LEVEL
COMPUTE WS-XML-LGTH = FUNCTION LENGTH(XML-TEXT)
MOVE XML-TEXT(1:WS-XML-LGTH)
TO WS-XML-ELEMENT(WS-XML-LEVEL)
MOVE WS-XML-ELEMENT(WS-XML-LEVEL)
TO WS-XML-FEJLELM
MOVE WS-XML-LGTH TO WS-XML-ELEMENT-LGTH(WS-XML-LEVEL)
MOVE 1 TO WS-XML-TEXT-LGTH
MOVE 0 TO WS-XML-ATTRIB-LEVEL
WHEN 'CONTENT-CHARACTERS'
WHEN 'CONTENT-CHARACTER'
* NB: Hvis content indeholder escape's (& etc) modtages
* content i bidder som skal stringes sammen
COMPUTE WS-XML-LGTH = FUNCTION LENGTH(XML-TEXT)
IF WS-XML-LGTH > 0
MOVE XML-TEXT(1:WS-XML-LGTH)
TO WS-TEMP-XML-TEXT(1: WS-XML-LGTH)
STRING WS-TEMP-XML-TEXT(1: WS-XML-LGTH)
DELIMITED BY SIZE INTO WS-XML-TEXT
POINTER WS-XML-TEXT-LGTH
MOVE '1' TO READY-FOR-OUTPUT-SW
END-IF
WHEN 'END-OF-ELEMENT'
IF READY-FOR-OUTPUT-SW = '1'
PERFORM DAN-UDDATA
MOVE ' ' TO READY-FOR-OUTPUT-SW
END-IF
SUBTRACT 1 FROM WS-XML-LEVEL
WS-XML-LEVEL-UNCHANGED
* 2006-10-05 tilføjet to linier: hvis "tekst"
MOVE 1 TO WS-XML-TEXT-LGTH
MOVE 0 TO WS-XML-ATTRIB-LEVEL
WHEN 'START-OF-DOCUMENT'
COMPUTE XML-DOCUMENT-LENGTH = FUNCTION LENGTH(XML-TEXT)
* WHEN 'END-OF-DOCUMENT'
* CONTINUE
* WHEN 'VERSION-INFORMATION'
* CONTINUE
* WHEN 'ENCODING-DECLARATION'
* CONTINUE
* WHEN 'STANDALONE-DECLARATION'
* CONTINUE
WHEN 'ATTRIBUTE-NAME'
ADD 1 TO WS-XML-ATTRIB-LEVEL
COMPUTE WS-XML-LGTH = FUNCTION LENGTH(XML-TEXT)
MOVE XML-TEXT(1:WS-XML-LGTH)
TO WS-XML-ATTRIB(WS-XML-ATTRIB-LEVEL)
MOVE WS-XML-ATTRIB(WS-XML-ATTRIB-LEVEL)
TO WS-XML-FEJLELM
MOVE WS-XML-LGTH
TO WS-XML-ATTRIB-LGTH(WS-XML-ATTRIB-LEVEL)
MOVE 1 TO WS-XML-ATTRIB-VALUE-LGTH(WS-XML-ATTRIB-LEVEL)
WHEN 'ATTRIBUTE-CHARACTERS'
WHEN 'ATTRIBUTE-CHARACTER'
COMPUTE WS-XML-LGTH = FUNCTION LENGTH(XML-TEXT)
IF WS-XML-LGTH > 0
MOVE XML-TEXT(1:WS-XML-LGTH)
TO WS-TEMP-XML-TEXT(1: WS-XML-LGTH)
STRING WS-TEMP-XML-TEXT(1: WS-XML-LGTH)
DELIMITED BY SIZE
INTO WS-XML-ATTRIB-VALUE(WS-XML-ATTRIB-LEVEL)
POINTER WS-XML-ATTRIB-VALUE-LGTH(WS-XML-ATTRIB-LEVEL)
MOVE '1' TO READY-FOR-OUTPUT-SW
END-IF
WHEN 'END-OF-INPUT'
PERFORM LAES-INPUT
WHEN 'EXCEPTION'
PERFORM XML-EXCEPTION
* WHEN 'START-OF-CDATA-SECTION'
* CONTINUE
* WHEN 'END-OF-CDATA-SECTION'
* CONTINUE
* WHEN 'PROCESSING-INSTRUCTION-TARGET'
* CONTINUE
* WHEN 'PROCESSING-INSTRUCTION-DATA'
* CONTINUE
* WHEN 'COMMENT'
* CONTINUE
* WHEN 'DOCUMENT-TYPE-DECLARATION'
* CONTINUE
* WHEN OTHER
* DISPLAY 'UNEXPECTED XML EVENT: ' XML-EVENT
END-EVALUATE
.
XML-HANDLER-EX.
EXIT.
XML-EXCEPTION SECTION.
MOVE 1 TO XML-UD-PTR
* MOVE XML-CODE TO DISPLAY-XML-CODE
* MOVE XML-DOCUMENT-LENGTH TO DISPLAY-XML-LGTH
* COMPUTE IX = XML-DOCUMENT-LENGTH - 15
* MOVE 15 TO IX
* IF IX < 1
* COMPUTE IX2 = 15 + IX
* MOVE 1 TO IX
* END-IF
* MOVE XML-TEXT(1:WS-XML-LGTH) TO
* WS-XML-TEXT (1:WS-XML-LGTH)
CALL 'FEJLUDTX' USING BY CONTENT 'XML'
BY REFERENCE XML-CODE
XML-FEJLTEKST
MOVE ZERO TO WSX-TALLY
INSPECT FUNCTION REVERSE(XML-FEJLTEKST) TALLYING WSX-TALLY
FOR LEADING SPACES
COMPUTE WSX-TALLY = 200 - WSX-TALLY
STRING
"RX_FMESS{Syntax error in XML input:"
DELIMITED BY SIZE
INTO XML-UD
POINTER XML-UD-PTR
IF WS-XML-FEJLELM NOT = SPACES
STRING
" Last Element: " WS-XML-FEJLELM
DELIMITED BY SIZE
INTO XML-UD
POINTER XML-UD-PTR
END-IF
STRING
"}"
DELIMITED BY SIZE
INTO XML-UD
POINTER XML-UD-PTR
STRING
" RX_FMESS2{"
XML-FEJLTEKST(1: WSX-TALLY)
"};"
DELIMITED BY SIZE
INTO XML-UD
POINTER XML-UD-PTR
SUBTRACT 1 FROM XML-UD-PTR
PERFORM SKRIV
MOVE 1 TO XML-UD-PTR
.
XML-EXCEPTION-EX.
EXIT.
LAES-INPUT SECTION.
* 2020-08-28: Radikalt forsimplet
* Der sendes fra RXS i individer a 7999 byte, det sidste mindre
* Evt. kun et individ...
* Tidligere forsøg på at fjerne whitespace inden og efter er fjernet
READ RXSINP
AT END
MOVE '1' TO EOF-SW
MOVE +0 TO XML-CODE
NOT AT END
MOVE RXSINP-LGTH TO WSRXSINP-LGTH
IF WSRXSINP-LGTH > 0
MOVE +1 TO XML-CODE
MOVE RXSINP-INDIVID(1: WSRXSINP-LGTH)
TO XML-IND(1:WSRXSINP-LGTH)
* 2020-11-05: Hvis RXS har delt i records a 7999 fjernes intet:
IF WSRXSINP-LGTH = 7999
MOVE '1' TO RXS-HAR-CONCAT-XML-INPUT
END-IF
IF RXS-HAR-CONCAT-XML-INPUT = ' '
* 2020-11-05 Fjern whitespace hvis linie slutter med afsluttet tag:
COMPUTE IX1 = FUNCTION LENGTH (FUNCTION TRIM(
XML-IND(1:WSRXSINP-LGTH) TRAILING))
IF IX1 > 0
IF XML-IND(IX1:1) = '>'
MOVE IX1 TO WSRXSINP-LGTH
END-IF
END-IF
* 2020-11-05 Fjern whitewpace foran hvis linie starter med tag:
COMPUTE IX2 = FUNCTION LENGTH (FUNCTION TRIM(
XML-IND(1:WSRXSINP-LGTH) LEADING))
IF IX2 < WSRXSINP-LGTH
COMPUTE IX3 = WSRXSINP-LGTH - IX2
IF XML-IND(IX3 + 1:1) = '<'
MOVE FUNCTION TRIM(XML-IND(1:WSRXSINP-LGTH) LEADING)
TO XML-IND(1:IX2)
MOVE IX2 TO WSRXSINP-LGTH
END-IF
END-IF
END-IF
* 2020-11-05 - slut
MOVE WSRXSINP-LGTH TO WS-IND-PTR
ELSE
MOVE +0 TO XML-CODE
* 2011-12-06: forhindr exception med nul-længde pointer
move ' ' to xml-ind(1:1)
move 1 to ws-ind-ptr
END-IF
END-READ
* 2020-11-05 Fjern whitespace hvis linie slutter med afsluttet tag:
* lagt ind ovenfor
* Problemet er
*
* killroy was here
*
*
* Hvis input er en fb-fil, står der en række whitespace efter
*
* Er dette en tag-værdi? XML fortolkeren siger 'ja', og tildeler
* værdien ' ' til main
* Dermed trigger RXS, og scriptet får overgivet at main = ' '
* Løsningen er at i indlæsningen fjerne al whitespace efter
* et '>'. Øvrige blanke kunne være en del af XML, fx:
*
* ''
* 'Killroy was '
* 'here'
* ''
* En sådan efterfølgende blank må aldrig fjernes
* (hvilket den nogen gange blev i 2018-udgaven af RXSDO)
*
* Whitespace foran '<' fjernes tilsvarende
.
LAES-INPUT-EX.
EXIT.
* LAES-INPUx SECTION.
* MOVE 1 TO WS-IND-PTR
* READ RXSINP
* AT END
* MOVE '1' TO EOF-SW
* MOVE +0 TO XML-CODE
* NOT AT END
* MOVE RXSINP-LGTH TO WSRXSINP-LGTH
* IF RXSINP-LGTH < 7999 AND FOERSTE-LAES = '1'
* * 2020-08-28: Dvs hvis vi i første indlæsning finder under 7999 byte
* * 2020-08-28: 'AND FOERSTE-LAES = 1' tilføjet
* display '€€€ regel: input < 7999' hovsa
* display RXSINP-INDIVID(1: RXSINP-LGTH) hovsa
* IF RXSINP-LGTH > 0
* MOVE ZERO TO WS-TALLY
* INSPECT RXSINP-INDIVID(1: RXSINP-LGTH)
* TALLYING WS-TALLY FOR LEADING SPACES
* IF WSRXSINP-LGTH - WS-TALLY > 1
* IF WS-IND-PTR > 1
* IF RXSINP-INDIVID(WS-TALLY + 1: 1) = '<'
* AND XML-IND(WS-IND-PTR - 1: 1) = SPACE
* SUBTRACT 1 FROM WS-IND-PTR
* END-IF
* END-IF
* STRING
* RXSINP-INDIVID(WS-TALLY + 1: RXSINP-LGTH - WS-TALLY) ' '
* DELIMITED BY SIZE INTO XML-IND
* POINTER WS-IND-PTR
* END-IF
* END-IF
* ELSE
* display '€€€ regel: input > 7999' hovsa
* * 2006-10-12:
* * hvis RXS har delt i individer a 7999 byte skal konkateneres brutalt:
* STRING
* RXSINP-INDIVID(1: RXSINP-LGTH)
* DELIMITED BY SIZE INTO XML-IND
* POINTER WS-IND-PTR
* END-IF
* * 2020-08-28: Næste if-sætning virker helt meningsløs i logikken:
* * - der ændres reelt ingenting?
* IF RXSINP-LGTH < 7999
* display '€€€ regel: input < 7999 / mystisk sub-regel ' hovsa
* * 2006-10-12:
* * hvis RXS har delt i individer a 7999 byte skal konkateneres brutalt:
* COMPUTE IX2 = WS-IND-PTR - 1
* * 2013-01-20 IF:
* IF IX2 > 0
* PERFORM VARYING IX FROM IX2 BY -1 UNTIL
* XML-IND-CHAR(IX) NOT = SPACE
* OR IX = 1
* END-PERFORM
* IF XML-IND-CHAR(IX) = '>'
* COMPUTE WS-IND-PTR = IX + 1
* ELSE
* COMPUTE WS-IND-PTR = IX + 2
* END-IF
* END-IF
* END-IF
* END-READ
* SUBTRACT 1 FROM WS-IND-PTR
* display '*** ws-ind-ptr: ' ws-ind-ptr hovsa
* display xml-ind(1:ws-ind-ptr) hovsa
* IF WS-IND-PTR > 0
* MOVE +1 TO XML-CODE
* ELSE
* MOVE +0 TO XML-CODE
* * 2011-12-06: forhindr exception med nul-længde pointer
* move 1 to ws-ind-ptr
* move ' ' to xml-ind(1:1)
* END-IF
* .
* LAES-INPUx-EX.
* EXIT.
DAN-UDDATA SECTION.
* Skriv liste over elementer:
MOVE WS-XML-LEVEL TO WS-9999
PERFORM VARYING IX FROM 1 BY 1 UNTIL IX > WS-XML-LEVEL
MOVE IX TO WS-9999
MOVE ZERO TO WS-TALLY
INSPECT WS-9999 TALLYING WS-TALLY FOR LEADING SPACES
STRING "XML." WS-9999(WS-TALLY + 1:) "{"
WS-XML-ELEMENT(IX)(1:WS-XML-ELEMENT-LGTH(IX))
"} "
DELIMITED BY SIZE
INTO XML-UD
POINTER XML-UD-PTR
END-PERFORM
* Skriv XML-content:
IF WS-XML-TEXT-LGTH > 1
SUBTRACT 1 FROM WS-XML-TEXT-LGTH
STRING "XML{"
WS-XML-TEXT(1:WS-XML-TEXT-LGTH) "} "
DELIMITED BY SIZE
INTO XML-UD
POINTER XML-UD-PTR
ELSE
STRING "XML{} "
DELIMITED BY SIZE
INTO XML-UD
POINTER XML-UD-PTR
END-IF
* Skriv liste over attribut-navne:
MOVE WS-XML-ATTRIB-LEVEL TO WS-9999
PERFORM VARYING IX FROM 1 BY 1 UNTIL IX > WS-XML-ATTRIB-LEVEL
MOVE IX TO WS-9999
MOVE ZERO TO WS-TALLY
INSPECT WS-9999 TALLYING WS-TALLY FOR LEADING SPACES
STRING "XML_ATTRIB." WS-9999(WS-TALLY + 1:) "{"
WS-XML-ATTRIB(IX)(1:WS-XML-ATTRIB-LGTH(IX))
"} "
DELIMITED BY SIZE
INTO XML-UD
POINTER XML-UD-PTR
END-PERFORM
* Tildel alle attribut-navne sin værdi:
PERFORM VARYING IX FROM 1 BY 1 UNTIL IX > WS-XML-ATTRIB-LEVEL
SUBTRACT 1 FROM WS-XML-ATTRIB-VALUE-LGTH(IX)
IF WS-XML-ATTRIB-VALUE-LGTH(IX) > 0
STRING WS-XML-ATTRIB(IX)(1:WS-XML-ATTRIB-LGTH(IX))
"{"
WS-XML-ATTRIB-VALUE(IX)(1:WS-XML-ATTRIB-VALUE-LGTH(IX))
"} "
DELIMITED BY SIZE
INTO XML-UD
POINTER XML-UD-PTR
ELSE
* Hvis en attribut er tom, tildeler vi den værdien blank:
STRING WS-XML-ATTRIB(IX)(1:WS-XML-ATTRIB-LGTH(IX))
"{"
"} "
DELIMITED BY SIZE
INTO XML-UD
POINTER XML-UD-PTR
END-IF
END-PERFORM
* Skriv Diverse tællere:
* MOVE WS-XML-LEVEL TO WS-9999
* WS-ELEM-CNT
* MOVE ZERO TO WS-TALLY
* INSPECT WS-9999 TALLYING WS-TALLY FOR LEADING SPACES
* STRING "XML_ELEM_CNT{"
* WS-9999(WS-TALLY + 1:)
* "} "
* DELIMITED BY SIZE
* INTO XML-UD
* POINTER XML-UD-PTR
MOVE WS-XML-LEVEL TO WS-9999
MOVE ZERO TO WS-TALLY
INSPECT WS-9999 TALLYING WS-TALLY FOR LEADING SPACES
STRING "XML.0{"
WS-9999(WS-TALLY + 1:)
"} "
DELIMITED BY SIZE
INTO XML-UD
POINTER XML-UD-PTR
STRING "XML_CNT{"
WS-9999(WS-TALLY + 1:)
"} "
DELIMITED BY SIZE
INTO XML-UD
POINTER XML-UD-PTR
* xml_attrib.0
* xml_attrib_cnt
MOVE WS-XML-ATTRIB-LEVEL TO WS-9999
MOVE ZERO TO WS-TALLY
INSPECT WS-9999 TALLYING WS-TALLY FOR LEADING SPACES
STRING "XML_ATTRIB.0{"
WS-9999(WS-TALLY + 1:)
"} "
DELIMITED BY SIZE
INTO XML-UD
POINTER XML-UD-PTR
STRING "XML_ATTRIB_CNT{"
WS-9999(WS-TALLY + 1:)
"} "
DELIMITED BY SIZE
INTO XML-UD
POINTER XML-UD-PTR
IF WS-XML-LEVEL-UNCHANGED > 0
MOVE WS-XML-LEVEL-UNCHANGED TO WS-9999
ELSE
MOVE ZERO TO WS-9999
END-IF
MOVE ZERO TO WS-TALLY
INSPECT WS-9999 TALLYING WS-TALLY FOR LEADING SPACES
STRING "XML_ELEM_UNCH{"
WS-9999(WS-TALLY + 1:)
"} "
DELIMITED BY SIZE
INTO XML-UD
POINTER XML-UD-PTR
* Skriv:
SUBTRACT 1 FROM XML-UD-PTR
STRING ";"
DELIMITED BY SIZE
INTO XML-UD
POINTER XML-UD-PTR
SUBTRACT 1 FROM XML-UD-PTR
PERFORM SKRIV
MOVE WS-XML-LEVEL TO WS-XML-LEVEL-UNCHANGED
* (xml-level-unchanged vil blive talt ned for hver efterfølgende
* end-of-element)
* Initialisering af attribut-værdier til næste svar:
MOVE 1 TO XML-UD-PTR
PERFORM VARYING IX FROM 1 BY 1 UNTIL IX > WS-XML-ATTRIB-LEVEL
STRING WS-XML-ATTRIB(IX)(1:WS-XML-ATTRIB-LGTH(IX))
"{} "
DELIMITED BY SIZE
INTO XML-UD
POINTER XML-UD-PTR
END-PERFORM
.
DAN-UDDATA-EX.
EXIT.
SKRIV SECTION.
IF XML-UD-PTR > 3000
MOVE 0 TO IX2
MOVE 3000 TO SKRIV-BLOK-PTR
PERFORM VARYING IX FROM 1 BY 1 UNTIL IX > XML-UD-PTR
IF IX > SKRIV-BLOK-PTR
AND XML-UD-CHAR(IX) = SPACE
ADD 1 TO IX2
MOVE IX TO SKRIV-BLOK-IX(IX2)
COMPUTE SKRIV-BLOK-PTR = IX + 3000
END-IF
END-PERFORM
ADD 1 TO IX2
ADD 1 TO XML-UD-PTR
MOVE XML-UD-PTR TO SKRIV-BLOK-IX(IX2)
MOVE 1 TO BLOK-START
PERFORM VARYING IX FROM 1 BY 1 UNTIL IX > IX2
COMPUTE RXSOUTP-LGTH = SKRIV-BLOK-IX(IX) - BLOK-START
MOVE RXSOUTP-LGTH TO WSRXSOUTP-LGTH
MOVE XML-UD(BLOK-START: WSRXSOUTP-LGTH)
TO RXSOUTP-INDIVID
WRITE RXSOUTP-INDIVID
MOVE SKRIV-BLOK-IX(IX) TO BLOK-START
END-PERFORM
ELSE
MOVE XML-UD-PTR TO RXSOUTP-LGTH
WSRXSOUTP-LGTH
MOVE XML-UD(1: XML-UD-PTR)
TO RXSOUTP-INDIVID
WRITE RXSOUTP-INDIVID
END-IF
.
SKRIV-EX.
EXIT.
END PROGRAM RXSXML.
* -----RXSMQ----------------------------------------------
IDENTIFICATION DIVISION.
PROGRAM-ID. RXSMQ.
*
* kaldmuligheder: (USING:)
* MQCONN QMGR
* udfører connect. Returnerer RX_MQHANDLE= i individ uddata
* MQBRW QNAME HANDLE
* MQGET QNAME HANDLE
* udfører mqopen, mqget, mqclose
* returnerer backoutcount + msgid + message i uddata
* fx
* ----+----1----+----2----+----3----+----4----+----5----+----6
* C 0001 123456789012345678901234 02042006 12:25:56 applnameap
* ----+----7----+----8----+----9----+----0----+----1----+----2
* plnameapplnameappl appltype--- I østen stiger solen op
* MQBROWS QNAME HANDLE
* udfører det samme, men i browse
* MQGETKEY QNAME HANDLE
* udfører det samme, men kun for anført key
* (dvs fjerner et message fra køen)
* MQPUT QNAME HANDLE
* udfører mqopen, mqget, mqclose
* læser input
* MQCMIT HANDLE
* udfører mq-single-commit (ved afslutning af RXS)
* MQDISC HANDLE
* udfører disconnect (ved afslutning af RXS)
*
* Ved fejl returneres i individ uddata:
* RX_FMESS=fejltekst RX_FMESS2=lang fejltekst
* Og sætter RETURN-CODE = REASONCODE fra MQ
*
*
DATA DIVISION.
WORKING-STORAGE SECTION.
01 LIBRATID PIC X(24) LIBRATID
VALUE 'LIBRATIDLIBRATIDLIBRATID'. LIBRATID
01 FILLER REDEFINES LIBRATID. LIBRATID
02 LT-PGMID-DTO-VERSION. LIBRATID
03 LT-PGMID PIC X(8). LIBRATID
03 LT-DTO-VERSION. LIBRATID
04 LT-DTO PIC X(6). LIBRATID
04 LT-VERSION PIC X(2). LIBRATID
02 LT-TID PIC X(8). LIBRATID
01 WSRXSINP-INDIVID.
02 WSRXSINP-CHAR PIC X OCCURS 8000.
01 WSRXSOUTP-INDIVID.
02 WSRXSOUTP-CHAR PIC X OCCURS 8000.
01 Z1 PIC S9(8) COMP.
01 WS-PARM-G.
02 WS-PARM-ELM PIC X(50) OCCURS 10.
01 WS-PARM-ANT PIC S9(4) COMP.
01 W03-WAITINTERVAL PIC S9(9) COMP VALUE 0.
01 MQ-QUEUE-MANAGER PIC X(48).
01 MQ-MSGLEN PIC S9(9) COMP VALUE 0.
01 MQ-CONNECT-HANDLE PIC S9(9) COMP VALUE 0.
* En separat handle pr kø der skal kunne behandles samtidigt:
01 MQ-HANDLE-THIS-QUEUE PIC S9(9) COMP VALUE 0.
01 MQ-SELCOUNT PIC S9(9) COMP VALUE 4.
01 MQ-OPENOPTIONS PIC S9(9) COMP.
01 MQ-COMPCODE PIC S9(9) COMP.
01 MQ-DATALEN PIC S9(9) COMP.
01 MQ-REASON PIC S9(9) COMP.
* waitinterval anføres i millisekunder:
01 MQM-OBJECT-DESCRIPTOR.
10 MQOD.
15 MQOD-STRUCID PIC X(4) VALUE 'OD '.
15 MQOD-VERSION PIC S9(9) BINARY VALUE 1.
15 MQOD-OBJECTTYPE PIC S9(9) BINARY VALUE 1.
15 MQOD-OBJECTNAME PIC X(48) VALUE SPACES.
15 MQOD-OBJECTQMGRNAME PIC X(48) VALUE SPACES.
15 MQOD-DYNAMICQNAME PIC X(48) VALUE 'CSQ.*'.
15 MQOD-ALTERNATEUSERID PIC X(12) VALUE SPACES.
15 MQOD-RECSPRESENT PIC S9(9) BINARY VALUE 0.
15 MQOD-KNOWNDESTCOUNT PIC S9(9) BINARY VALUE 0.
15 MQOD-UNKNOWNDESTCOUNT PIC S9(9) BINARY VALUE 0.
15 MQOD-INVALIDDESTCOUNT PIC S9(9) BINARY VALUE 0.
15 MQOD-OBJECTRECOFFSET PIC S9(9) BINARY VALUE 0.
15 MQOD-RESPONSERECOFFSET PIC S9(9) BINARY VALUE 0.
15 MQOD-OBJECTRECPTR POINTER VALUE NULL.
15 MQOD-RESPONSERECPTR POINTER VALUE NULL.
15 MQOD-ALTERNATESECURITYID PIC X(40) VALUE LOW-VALUES.
15 MQOD-RESOLVEDQNAME PIC X(48) VALUE SPACES.
15 MQOD-RESOLVEDQMGRNAME PIC X(48) VALUE SPACES.
01 MQM-MESSAGE-DESCRIPTOR.
10 MQMD.
15 MQMD-STRUCID PIC X(4) VALUE 'MD '.
15 MQMD-VERSION PIC S9(9) BINARY VALUE 1.
15 MQMD-REPORT PIC S9(9) BINARY VALUE 0.
15 MQMD-MSGTYPE PIC S9(9) BINARY VALUE 8.
15 MQMD-EXPIRY PIC S9(9) BINARY VALUE -1.
15 MQMD-FEEDBACK PIC S9(9) BINARY VALUE 0.
15 MQMD-ENCODING PIC S9(9) BINARY VALUE 785.
15 MQMD-CODEDCHARSETID PIC S9(9) BINARY VALUE 0.
15 MQMD-FORMAT PIC X(8) VALUE SPACES.
15 MQMD-PRIORITY PIC S9(9) BINARY VALUE -1.
15 MQMD-PERSISTENCE PIC S9(9) BINARY VALUE 2.
15 MQMD-MSGID PIC X(24) VALUE LOW-VALUES.
15 MQMD-CORRELID PIC X(24) VALUE LOW-VALUES.
15 MQMD-BACKOUTCOUNT PIC S9(9) BINARY VALUE 0.
15 MQMD-REPLYTOQ PIC X(48) VALUE SPACES.
15 MQMD-REPLYTOQMGR PIC X(48) VALUE SPACES.
15 MQMD-USERIDENTIFIER PIC X(12) VALUE SPACES.
15 MQMD-ACCOUNTINGTOKEN PIC X(32) VALUE LOW-VALUES.
15 MQMD-APPLIDENTITYDATA PIC X(32) VALUE SPACES.
15 MQMD-PUTAPPLTYPE PIC S9(9) BINARY VALUE 0.
15 MQMD-PUTAPPLNAME PIC X(28) VALUE SPACES.
15 MQMD-PUTDATE PIC X(8) VALUE SPACES.
15 MQMD-PUTTIME PIC X(8) VALUE SPACES.
15 MQMD-APPLORIGINDATA PIC X(4) VALUE SPACES.
01 MQM-GET-MESSAGE-OPTIONS.
10 MQGMO.
15 MQGMO-STRUCID PIC X(4) VALUE 'GMO '.
15 MQGMO-VERSION PIC S9(9) BINARY VALUE 1.
15 MQGMO-OPTIONS PIC S9(9) BINARY VALUE 0.
15 MQGMO-WAITINTERVAL PIC S9(9) BINARY VALUE 0.
15 MQGMO-SIGNAL1 POINTER VALUE NULL.
15 MQGMO-SIGNAL2 PIC S9(9) BINARY VALUE 0.
15 MQGMO-RESOLVEDQNAME PIC X(48) VALUE SPACES.
15 MQGMO-MATCHOPTIONS PIC S9(9) BINARY VALUE 3.
15 MQGMO-GROUPSTATUS PIC X VALUE ' '.
15 MQGMO-SEGMENTSTATUS PIC X VALUE ' '.
15 MQGMO-SEGMENTATION PIC X VALUE ' '.
15 MQGMO-RESERVED1 PIC X VALUE SPACES.
15 MQGMO-MSGTOKEN PIC X(16) VALUE LOW-VALUES.
15 MQGMO-RETURNEDLENGTH PIC S9(9) BINARY VALUE -1.
01 MQM-PUT-MESSAGE-OPTIONS.
10 MQPMO.
15 MQPMO-STRUCID PIC X(4) VALUE 'PMO '.
15 MQPMO-VERSION PIC S9(9) BINARY VALUE 1.
15 MQPMO-OPTIONS PIC S9(9) BINARY VALUE 0.
15 MQPMO-TIMEOUT PIC S9(9) BINARY VALUE -1.
15 MQPMO-CONTEXT PIC S9(9) BINARY VALUE 0.
15 MQPMO-KNOWNDESTCOUNT PIC S9(9) BINARY VALUE 0.
15 MQPMO-UNKNOWNDESTCOUNT PIC S9(9) BINARY VALUE 0.
15 MQPMO-INVALIDDESTCOUNT PIC S9(9) BINARY VALUE 0.
15 MQPMO-RESOLVEDQNAME PIC X(48) VALUE SPACES.
15 MQPMO-RESOLVEDQMGRNAME PIC X(48) VALUE SPACES.
* MQV contains constants (for filling in the control blocks)
* and return codes (for testing the result of a call)
01 MQM-CONSTANTS.
10 MQGMO-NO-WAIT PIC S9(9) BINARY VALUE 0.
10 MQGMO-SYNCPOINT PIC S9(9) BINARY VALUE 2.
10 MQGMO-NO-SYNCPOINT PIC S9(9) BINARY VALUE 4.
10 MQGMO-BROWSE-NEXT PIC S9(9) BINARY VALUE 32.
10 MQFMT-STRING PIC X(8) VALUE 'MQSTR '.
10 MQPER-NOT-PERSISTENT PIC S9(9) BINARY VALUE 0.
10 MQMI-NONE PIC X(24) VALUE LOW-VALUES.
10 MQCI-NONE PIC X(24) VALUE LOW-VALUES.
10 MQOO-INPUT-SHARED PIC S9(9) BINARY VALUE 2.
10 MQOO-BROWSE PIC S9(9) BINARY VALUE 8.
10 MQOO-OUTPUT PIC S9(9) BINARY VALUE 16.
10 MQCO-NONE PIC S9(9) BINARY VALUE 0.
01 EOF-SW PIC X.
01 WS-DISPLAY-NUM-G.
02 WS-DISPLAY-NUM PIC 9(9).
01 DISPLAY-BACKOUTCOUNT-G.
02 DISPLAY-BACKOUTCOUNT PIC 9(4).
01 WS-FEJLSTED PIC X(8).
01 DISPLAY-MQ-REASON-G.
02 DISPLAY-MQ-REASON PIC 9(4).
01 WS-UD-PTR PIC S9(8) COMP.
01 MQ-FEJLTEKST PIC X(200).
01 WSX-TALLY PIC S9(8) COMP.
01 WS-SHORTMESS PIC X(25).
01 WS-LONGMESS PIC X(50).
01 RXSOUTP-SW PIC X VALUE SPACE.
01 WS-GETKEY PIC X(24).
01 MQLIMIT PIC S9(8) COMP.
01 WS-TAEL PIC S9(8) COMP.
01 WS-LGTH PIC S9(8) COMP.
01 WS-STRT PIC S9(8) COMP.
01 WS-POINTER-1 POINTER.
01 WS-POINTER-2 POINTER.
01 WS-POINTER-3 POINTER.
01 WS-POINTER-4 POINTER.
01 WS-POINTER-5 POINTER.
01 WS-POINTER-6 POINTER.
01 WS-DONE PIC X.
01 WS-APPLTYPE PIC X(11).
LINKAGE SECTION.
01 LINK-PARM-G.
02 LINK-PARM-LGTH PIC S9(4) COMP-5.
02 LINK-PARM PIC X(31500).
01 WS-MQ-3M-MESSAGE PIC X(3000100).
* (comp-5 vil sige: op til 32.000 i value)
PROCEDURE DIVISION USING LINK-PARM-G.
MOVE ZERO TO WS-PARM-ANT
MOVE 1 TO Z1
PERFORM UNTIL Z1 > LINK-PARM-LGTH
ADD 1 TO WS-PARM-ANT
MOVE SPACES TO WS-PARM-ELM(WS-PARM-ANT)
UNSTRING LINK-PARM(1: LINK-PARM-LGTH) DELIMITED
BY ALL SPACES INTO WS-PARM-ELM(WS-PARM-ANT)
POINTER Z1
IF WS-PARM-ELM(WS-PARM-ANT) = SPACES
MOVE 30000 TO Z1
END-IF
END-PERFORM
CALL 'RXSGEM' USING WS-POINTER-1
WS-POINTER-2
WS-POINTER-3
WS-POINTER-4
WS-POINTER-5
WS-POINTER-6
SET ADDRESS OF WS-MQ-3M-MESSAGE TO WS-POINTER-1
MOVE SPACES TO WS-GETKEY
EVALUATE WS-PARM-ELM(1)
WHEN 'MQCONN'
MOVE WS-PARM-ELM(2) TO MQ-QUEUE-MANAGER
PERFORM CONNECT-MQ
MOVE MQ-CONNECT-HANDLE TO WS-DISPLAY-NUM
OPEN OUTPUT RXSOUTP
MOVE '1' TO RXSOUTP-SW
MOVE 1 TO WSRXSOUTP-LGTH
STRING 'RX_MQHANDLE='
WS-DISPLAY-NUM-G
DELIMITED BY SIZE INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
SUBTRACT 1 FROM WSRXSOUTP-LGTH
MOVE WSRXSOUTP-LGTH TO RXSOUTP-LGTH
MOVE WSRXSOUTP-INDIVID(1:WSRXSOUTP-LGTH)
TO RXSOUTP-INDIVID(1:RXSOUTP-LGTH)
WRITE RXSOUTP-INDIVID
CLOSE RXSOUTP
MOVE ' ' TO RXSOUTP-SW
WHEN 'MQBRW'
WHEN 'MQGET'
MOVE WS-PARM-ELM(2) TO MQOD-OBJECTNAME
COMPUTE MQ-CONNECT-HANDLE =
FUNCTION NUMVAL(WS-PARM-ELM(3))
COMPUTE MQLIMIT =
FUNCTION NUMVAL(WS-PARM-ELM(4))
IF WS-PARM-ELM(1) = 'MQBRW'
MOVE MQOO-BROWSE TO MQ-OPENOPTIONS
ELSE
MOVE MQOO-INPUT-SHARED TO MQ-OPENOPTIONS
END-IF
PERFORM OPEN-MQ
OPEN OUTPUT RXSOUTP
MOVE '1' TO RXSOUTP-SW
MOVE ZERO TO WS-TAEL
PERFORM UNTIL MQ-REASON NOT = ZERO
OR WS-TAEL >= MQLIMIT
PERFORM GET-MQ
END-PERFORM
PERFORM CLOSE-MQ
CLOSE RXSOUTP
MOVE ' ' TO RXSOUTP-SW
WHEN 'MQGETKEY'
MOVE WS-PARM-ELM(2) TO MQOD-OBJECTNAME
COMPUTE MQ-CONNECT-HANDLE =
FUNCTION NUMVAL(WS-PARM-ELM(3))
MOVE MQOO-INPUT-SHARED TO MQ-OPENOPTIONS
OPEN INPUT RXSINP
MOVE ' ' TO EOF-SW
PERFORM UNTIL EOF-SW = '1'
PERFORM LAES-RXSINP
IF EOF-SW NOT = '1'
MOVE RXSINP-LGTH TO WSRXSINP-LGTH
MOVE RXSINP-INDIVID(1:RXSINP-LGTH) TO
WSRXSINP-INDIVID(1:WSRXSINP-LGTH)
END-IF
END-PERFORM
CLOSE RXSINP
MOVE WSRXSINP-INDIVID(1:WSRXSINP-LGTH) TO WS-GETKEY
PERFORM OPEN-MQ
OPEN OUTPUT RXSOUTP
MOVE '1' TO RXSOUTP-SW
PERFORM GET-MQ
PERFORM CLOSE-MQ
CLOSE RXSOUTP
MOVE ' ' TO RXSOUTP-SW
WHEN 'MQPUT'
MOVE WS-PARM-ELM(2) TO MQOD-OBJECTNAME
COMPUTE MQ-CONNECT-HANDLE =
FUNCTION NUMVAL(WS-PARM-ELM(3))
MOVE MQOO-OUTPUT TO MQ-OPENOPTIONS
PERFORM OPEN-MQ
OPEN INPUT RXSINP
MOVE ' ' TO EOF-SW
PERFORM UNTIL EOF-SW = '1'
PERFORM LAES-RXSINP
IF EOF-SW NOT = '1'
MOVE 1 TO WS-LGTH
MOVE ' ' TO WS-DONE
PERFORM UNTIL WS-DONE = '1'
IF RXSINP-LGTH > 1
STRING RXSINP-INDIVID(2:RXSINP-LGTH - 1)
DELIMITED BY SIZE INTO WS-MQ-3M-MESSAGE
POINTER WS-LGTH
END-STRING
END-IF
IF RXSINP-INDIVID(1:1) = ' '
MOVE '1' TO WS-DONE
ELSE
PERFORM LAES-RXSINP
IF EOF-SW = '1'
MOVE "Internal error" TO WS-SHORTMESS
MOVE
"MQ: Internal error: Reading after eof RXSDO"
TO WS-LONGMESS
PERFORM MQ-EXCEPTION-2
END-IF
END-IF
END-PERFORM
COMPUTE WSRXSINP-LGTH = WS-LGTH - 1
IF WSRXSINP-LGTH > 3000000
MOVE "Length exhausted" TO WS-SHORTMESS
MOVE
"MQPUT: Message length is over 3,000,000 bytes"
TO WS-LONGMESS
PERFORM MQ-EXCEPTION-2
END-IF
PERFORM PUT-MQ
END-IF
END-PERFORM
CLOSE RXSINP
PERFORM CLOSE-MQ
WHEN 'MQCMIT'
COMPUTE MQ-CONNECT-HANDLE =
FUNCTION NUMVAL(WS-PARM-ELM(2))
PERFORM COMMIT-MQ
WHEN 'MQDISC'
COMPUTE MQ-CONNECT-HANDLE =
FUNCTION NUMVAL(WS-PARM-ELM(2))
PERFORM DISCONNECT-MQ
END-EVALUATE
MOVE ZERO TO RETURN-CODE
GOBACK.
LAES-RXSINP SECTION.
READ RXSINP
AT END
MOVE '1' TO EOF-SW
NOT AT END
MOVE RXSINP-LGTH TO WSRXSINP-LGTH
END-READ
.
LAES-RXSINP-EX.
EXIT.
GET-MQ SECTION.
MOVE MQGMO-NO-WAIT TO MQGMO-OPTIONS
* ADD MQGMO-ACCEPT-TRUNCATED-MSG TO MQGMO-OPTIONS
* ADD MQGMO-CONVERT TO MQGMO-OPTIONS
* ADD MQGMO-WAIT TO MQGMO-OPTIONS
* return immidiate if no suitable message:
IF WS-PARM-ELM(1) = 'MQBRW'
* browse i køen:
ADD MQGMO-NO-SYNCPOINT TO MQGMO-OPTIONS
ADD MQGMO-BROWSE-NEXT TO MQGMO-OPTIONS
ELSE
* get message with syncpoint control:
ADD MQGMO-SYNCPOINT TO MQGMO-OPTIONS
END-IF
MOVE MQPER-NOT-PERSISTENT TO MQMD-PERSISTENCE
MOVE 16000000 TO MQ-MSGLEN
MOVE ZERO TO MQGMO-WAITINTERVAL
*** MOVE 277 TO MQMD-CODEDCHARSETID
MOVE MQMI-NONE TO MQMD-MSGID
MOVE MQCI-NONE TO MQMD-CORRELID
IF WS-GETKEY NOT = SPACES
MOVE WS-GETKEY TO MQMD-MSGID
END-IF
CALL 'MQGET' USING MQ-CONNECT-HANDLE
MQ-HANDLE-THIS-QUEUE
MQMD
MQGMO
MQ-MSGLEN
WS-MQ-3M-MESSAGE
MQ-DATALEN
MQ-COMPCODE
MQ-REASON
EVALUATE MQ-REASON
WHEN ZERO
* (2079: accept truncated message did happen):
* WHEN 2079
MOVE 1 TO WS-STRT
PERFORM UNTIL WS-STRT > MQ-DATALEN
COMPUTE WS-LGTH = MQ-DATALEN - WS-STRT + 1
MOVE SPACE TO WSRXSOUTP-INDIVID(1:1)
IF WS-LGTH > 7900
MOVE 7900 TO WS-LGTH
MOVE 'C' TO WSRXSOUTP-INDIVID(1:1)
END-IF
MOVE WS-MQ-3M-MESSAGE(WS-STRT:WS-LGTH)
TO WSRXSOUTP-INDIVID(92:WS-LGTH)
ADD 7900 TO WS-STRT
MOVE MQMD-BACKOUTCOUNT TO DISPLAY-BACKOUTCOUNT
MOVE DISPLAY-BACKOUTCOUNT TO
WSRXSOUTP-INDIVID(3:4)
MOVE MQMD-MSGID TO WSRXSOUTP-INDIVID(8:24)
MOVE SPACE TO WSRXSOUTP-INDIVID(32:1)
MOVE MQMD-PUTDATE TO WSRXSOUTP-INDIVID(33:8)
MOVE SPACE TO WSRXSOUTP-INDIVID(41:1)
MOVE MQMD-PUTTIME TO WSRXSOUTP-INDIVID(42:8)
MOVE SPACE TO WSRXSOUTP-INDIVID(50:1)
MOVE MQMD-PUTAPPLNAME TO WSRXSOUTP-INDIVID(51:28)
MOVE SPACE TO WSRXSOUTP-INDIVID(79:1)
EVALUATE MQMD-PUTAPPLTYPE
WHEN -1
MOVE 'UNKNOWN ' TO WS-APPLTYPE
WHEN 0
MOVE 'NO-CONTEXT' TO WS-APPLTYPE
WHEN 1
MOVE 'CICS ' TO WS-APPLTYPE
WHEN 2
MOVE 'OS390 ' TO WS-APPLTYPE
WHEN 3
MOVE 'IMS ' TO WS-APPLTYPE
WHEN 4
MOVE 'OS2 ' TO WS-APPLTYPE
WHEN 5
MOVE 'DOS ' TO WS-APPLTYPE
WHEN 6
MOVE 'UNIX ' TO WS-APPLTYPE
WHEN 7
MOVE 'QMGR ' TO WS-APPLTYPE
WHEN 8
MOVE 'OS400 ' TO WS-APPLTYPE
WHEN 9
MOVE 'WINDOWS ' TO WS-APPLTYPE
WHEN 10
MOVE 'CICS-VSE ' TO WS-APPLTYPE
WHEN 11
MOVE 'WINDOWS-NT' TO WS-APPLTYPE
WHEN 12
MOVE 'VMS ' TO WS-APPLTYPE
WHEN 13
MOVE 'GUARDIAN ' TO WS-APPLTYPE
WHEN 14
MOVE 'VOS ' TO WS-APPLTYPE
WHEN 19
MOVE 'IMS-BRIDGE' TO WS-APPLTYPE
WHEN 20
MOVE 'XCF ' TO WS-APPLTYPE
WHEN 21
MOVE 'CICS-BRIDGE' TO WS-APPLTYPE
WHEN 22
MOVE 'NOTES-AGENT' TO WS-APPLTYPE
WHEN 26
MOVE 'BROKER ' TO WS-APPLTYPE
WHEN 28
MOVE 'JAVA ' TO WS-APPLTYPE
WHEN 29
MOVE 'DQM ' TO WS-APPLTYPE
WHEN 65536
MOVE 'USER-FIRST' TO WS-APPLTYPE
WHEN 999999999
MOVE 'USER-LAST ' TO WS-APPLTYPE
WHEN ANY
MOVE SPACES TO WS-APPLTYPE
END-EVALUATE
MOVE WS-APPLTYPE TO WSRXSOUTP-INDIVID(80:11)
MOVE SPACE TO WSRXSOUTP-INDIVID(91:1)
COMPUTE WSRXSOUTP-LGTH = 91 + WS-LGTH
MOVE WSRXSOUTP-LGTH TO RXSOUTP-LGTH
MOVE WSRXSOUTP-INDIVID(1:WSRXSOUTP-LGTH)
TO RXSOUTP-INDIVID(1:RXSOUTP-LGTH)
WRITE RXSOUTP-INDIVID
END-PERFORM
ADD 1 TO WS-TAEL
WHEN 2033
* end-of-file
CONTINUE
WHEN ANY
MOVE 'MQGET' TO WS-FEJLSTED
PERFORM MQ-EXCEPTION
END-EVALUATE
.
GET-MQ-EX.
EXIT.
PUT-MQ SECTION.
MOVE MQMI-NONE TO MQMD-MSGID
MOVE MQCI-NONE TO MQMD-CORRELID
* MOVE MQGMO-NO-SYNCPOINT TO MQPMO-OPTIONS
* (indikerer at det er en streng af char - ingen pakkede o.l.):
MOVE MQFMT-STRING TO MQMD-FORMAT
CALL 'MQPUT' USING MQ-CONNECT-HANDLE
MQ-HANDLE-THIS-QUEUE
MQMD
MQPMO
WSRXSINP-LGTH
WS-MQ-3M-MESSAGE
MQ-COMPCODE
MQ-REASON
IF MQ-REASON NOT = ZERO
MOVE 'MQPUT' TO WS-FEJLSTED
PERFORM MQ-EXCEPTION
END-IF
.
PUT-MQ-EX.
EXIT.
MQ-EXCEPTION SECTION.
IF RXSOUTP-SW = ' '
OPEN OUTPUT RXSOUTP
MOVE '1' TO RXSOUTP-SW
END-IF
MOVE 1 TO WSRXSOUTP-LGTH
MOVE MQ-REASON TO DISPLAY-MQ-REASON
EVALUATE MQ-REASON
WHEN 2058
STRING "RX_FMESS='MQ: No such queuemanager: "
DELIMITED BY SIZE
MQ-QUEUE-MANAGER
DELIMITED BY SPACE
"';"
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
STRING
"RX_FMESS2='on this installation'"
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
WHEN 2085
STRING "RX_FMESS='MQ: "
DELIMITED BY SIZE
MQOD-OBJECTNAME
DELIMITED BY SPACE
" not found"
"';"
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
STRING "RX_FMESS2='on current qmanager'"
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
WHEN 2079
WHEN 2080
CALL 'FEJLUDTX' USING BY CONTENT 'MQ'
BY REFERENCE MQ-REASON
MQ-FEJLTEKST
MOVE ZERO TO WSX-TALLY
INSPECT FUNCTION REVERSE(MQ-FEJLTEKST) TALLYING WSX-TALLY
FOR LEADING SPACES
COMPUTE WSX-TALLY = 200 - WSX-TALLY
STRING
"RX_FMESS='Error in calling IBM MQ: "
WS-FEJLSTED
"';"
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
STRING
" RX_FMESS2='"
DISPLAY-MQ-REASON-G ": "
MQ-FEJLTEKST(1: WSX-TALLY)
" (max message length is 3,000,000)"
"'"
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
WHEN ANY
CALL 'FEJLUDTX' USING BY CONTENT 'MQ'
BY REFERENCE MQ-REASON
MQ-FEJLTEKST
MOVE ZERO TO WSX-TALLY
INSPECT FUNCTION REVERSE(MQ-FEJLTEKST) TALLYING WSX-TALLY
FOR LEADING SPACES
COMPUTE WSX-TALLY = 200 - WSX-TALLY
STRING
"RX_FMESS='Error in calling IBM MQ: "
WS-FEJLSTED
"';"
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
STRING
" RX_FMESS2='"
DISPLAY-MQ-REASON-G ": "
MQ-FEJLTEKST(1: WSX-TALLY)
"'"
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
END-EVALUATE
SUBTRACT 1 FROM WSRXSOUTP-LGTH
MOVE WSRXSOUTP-LGTH TO RXSOUTP-LGTH
MOVE WSRXSOUTP-INDIVID TO RXSOUTP-INDIVID
WRITE RXSOUTP-INDIVID
CLOSE RXSOUTP
MOVE ' ' TO RXSOUTP-SW
MOVE MQ-REASON TO RETURN-CODE
GOBACK
.
MQ-EXCEPTION-EX.
EXIT.
MQ-EXCEPTION-2 SECTION.
MOVE 1 TO WSRXSOUTP-LGTH
IF RXSOUTP-SW = ' '
OPEN OUTPUT RXSOUTP
MOVE '1' TO RXSOUTP-SW
END-IF
STRING
"RX_FMESS='" WS-SHORTMESS
"';"
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
STRING
" RX_FMESS2='"
WS-LONGMESS
"'"
DELIMITED BY SIZE
INTO WSRXSOUTP-INDIVID
POINTER WSRXSOUTP-LGTH
SUBTRACT 1 FROM WSRXSOUTP-LGTH
MOVE WSRXSOUTP-LGTH TO RXSOUTP-LGTH
MOVE WSRXSOUTP-INDIVID TO RXSOUTP-INDIVID
WRITE RXSOUTP-INDIVID
CLOSE RXSOUTP
MOVE ' ' TO RXSOUTP-SW
MOVE 999 TO RETURN-CODE
GOBACK
.
MQ-EXCEPTION-2-EX.
EXIT.
CONNECT-MQ SECTION.
CALL 'MQCONN' USING MQ-QUEUE-MANAGER
MQ-CONNECT-HANDLE
MQ-COMPCODE
MQ-REASON
EVALUATE MQ-REASON
WHEN ZERO
CONTINUE
WHEN 2002
* (already connected)
CONTINUE
WHEN ANY
MOVE 'MQCONN' TO WS-FEJLSTED
PERFORM MQ-EXCEPTION
END-EVALUATE
.
CONNECT-MQ-EX.
EXIT.
OPEN-MQ SECTION.
CALL 'MQOPEN' USING MQ-CONNECT-HANDLE
MQOD
MQ-OPENOPTIONS
MQ-HANDLE-THIS-QUEUE
MQ-COMPCODE
MQ-REASON
EVALUATE MQ-REASON
WHEN ZERO
CONTINUE
* WHEN 2018
* (HCONN error - vi har ikke en valid handle)
WHEN ANY
MOVE 'MQOPEN' TO WS-FEJLSTED
PERFORM MQ-EXCEPTION
END-EVALUATE
.
OPEN-MQ-EX.
EXIT.
CLOSE-MQ SECTION.
CALL 'MQCLOSE' USING MQ-CONNECT-HANDLE
MQ-HANDLE-THIS-QUEUE
MQCO-NONE
MQ-COMPCODE
MQ-REASON
IF MQ-REASON NOT = ZERO
MOVE 'MQCLOSE' TO WS-FEJLSTED
PERFORM MQ-EXCEPTION
END-IF
.
CLOSE-MQ-EX.
EXIT.
COMMIT-MQ SECTION.
CALL 'MQCMIT' USING MQ-CONNECT-HANDLE
MQ-COMPCODE
MQ-REASON
IF MQ-REASON NOT = ZERO
MOVE 'MQCMIT' TO WS-FEJLSTED
PERFORM MQ-EXCEPTION
END-IF
.
COMMIT-MQ-EX.
EXIT.
DISCONNECT-MQ SECTION.
CALL 'MQDISC' USING MQ-CONNECT-HANDLE
MQ-COMPCODE
MQ-REASON
IF MQ-REASON NOT = ZERO
MOVE 'MQDISC' TO WS-FEJLSTED
PERFORM MQ-EXCEPTION
END-IF
.
DISCONNECT-MQ-EX.
EXIT.
END PROGRAM RXSMQ.
IDENTIFICATION DIVISION.
PROGRAM-ID. RXSCONV.
* konverteringer til / fra ascii / utf-8, især i forbindelse med
* mainframe-unix
ENVIRONMENT DIVISION.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 LIBRATID PIC X(24) LIBRATID
VALUE 'LIBRATIDLIBRATIDLIBRATID'. LIBRATID
01 FILLER REDEFINES LIBRATID. LIBRATID
02 LT-PGMID-DTO-VERSION. LIBRATID
03 LT-PGMID PIC X(8). LIBRATID
03 LT-DTO-VERSION. LIBRATID
04 LT-DTO PIC X(6). LIBRATID
04 LT-VERSION PIC X(2). LIBRATID
02 LT-TID PIC X(8). LIBRATID
01 Z1 PIC S9(8) COMP.
01 XX PIC S9(8) COMP.
01 YY PIC S9(8) COMP.
01 ZZ PIC S9(8) COMP.
01 WS-PARM-G.
02 WS-PARM-ELM PIC X(50) OCCURS 10.
01 EOF-SW PIC X VALUE ' '.
01 WS-PARM-ANT PIC S9(4) COMP.
01 WS-ASCII-CCSID PIC 9(4) COMP.
01 WS-EBCDIC-CCSID PIC 9(4) COMP.
01 WS-UNICODE-CCSID PIC 9(4) COMP VALUE 1208.
01 UNICODE-UTF-16-STRING-G.
02 UNICODE-UTF-16-STRING PIC N(8000) USAGE NATIONAL.
01 UTF-8-STRING PIC X(16000).
01 DISPLAY-STRING PIC X(8000).
01 WS-REST-INDIVID PIC X(8004).
01 WS-REST-LGTH PIC S9(8) COMP VALUE ZERO.
LINKAGE SECTION.
01 LINK-PARM-G.
02 LINK-PARM-LGTH PIC S9(4) COMP-5.
02 LINK-PARM PIC X(31500).
PROCEDURE DIVISION USING LINK-PARM-G.
MOVE ZERO TO WS-PARM-ANT
MOVE 1 TO Z1
PERFORM UNTIL Z1 > LINK-PARM-LGTH
ADD 1 TO WS-PARM-ANT
MOVE SPACES TO WS-PARM-ELM(WS-PARM-ANT)
UNSTRING LINK-PARM(1: LINK-PARM-LGTH) DELIMITED
BY ALL SPACES INTO WS-PARM-ELM(WS-PARM-ANT)
POINTER Z1
IF WS-PARM-ELM(WS-PARM-ANT) = SPACES
MOVE 30000 TO Z1
END-IF
END-PERFORM
COMPUTE WS-ASCII-CCSID = FUNCTION NUMVAL(WS-PARM-ELM(2))
COMPUTE WS-EBCDIC-CCSID = FUNCTION NUMVAL(WS-PARM-ELM(3))
OPEN INPUT RXSINP
OPEN OUTPUT RXSOUTP
MOVE ' ' TO EOF-SW
PERFORM UNTIL EOF-SW = '1'
READ RXSINP
AT END
MOVE '1' TO EOF-SW
NOT AT END
* 2010-03-18:
MOVE RXSINP-LGTH TO WSRXSINP-LGTH
* 2011-01-12:
IF RXSINP-LGTH > 0
EVALUATE WS-PARM-ELM(1)
WHEN 'TASCII'
PERFORM CONVERT-TO-ASCII
WHEN 'FASCII'
PERFORM CONVERT-FROM-ASCII
WHEN 'TUTF8'
PERFORM CONVERT-TO-UTF-8
WHEN 'FUTF8'
PERFORM CONVERT-FROM-UTF-8
WHEN 'NOCONV'
PERFORM NOCONVERT
WHEN 'ASCINL'
PERFORM ASCII-NEWLINE
END-EVALUATE
END-IF
END-READ
END-PERFORM
CLOSE RXSINP
CLOSE RXSOUTP
GOBACK.
CONVERT-TO-ASCII SECTION.
MOVE RXSINP-LGTH TO RXSOUTP-LGTH
WSRXSOUTP-LGTH
MOVE FUNCTION DISPLAY-OF (
FUNCTION NATIONAL-OF (
RXSINP-INDIVID(1:RXSINP-LGTH)
WS-EBCDIC-CCSID
)
WS-ASCII-CCSID
)
TO RXSOUTP-INDIVID(1:RXSOUTP-LGTH)
WRITE RXSOUTP-INDIVID
.
CONVERT-TO-ASCII-EX.
EXIT.
ASCII-NEWLINE SECTION.
COMPUTE RXSOUTP-LGTH = RXSINP-LGTH + 1
MOVE RXSOUTP-LGTH TO WSRXSOUTP-LGTH
MOVE FUNCTION DISPLAY-OF (
FUNCTION NATIONAL-OF (
RXSINP-INDIVID(1:RXSINP-LGTH)
WS-EBCDIC-CCSID
)
WS-ASCII-CCSID
)
TO RXSOUTP-INDIVID(1:RXSINP-LGTH)
MOVE X'15' TO RXSOUTP-INDIVID(RXSOUTP-LGTH:1)
WRITE RXSOUTP-INDIVID
.
ASCII-NEWLINE-EX.
EXIT.
NOCONVERT SECTION.
MOVE RXSINP-LGTH TO RXSOUTP-LGTH
MOVE RXSOUTP-LGTH TO WSRXSOUTP-LGTH
IF RXSOUTP-LGTH > 0
MOVE RXSINP-INDIVID(1:RXSINP-LGTH)
TO RXSOUTP-INDIVID(1:RXSOUTP-LGTH)
WRITE RXSOUTP-INDIVID
END-IF
.
NOCONVERT-EX.
EXIT.
CONVERT-FROM-UTF-8 SECTION.
MOVE RXSINP-LGTH TO ZZ
CALL 'FRAUTF8' USING RXSINP-INDIVID
ZZ
DISPLAY-STRING
YY
WS-EBCDIC-CCSID
* MOVE 1 TO YY
* STRING FUNCTION NATIONAL-OF (
* RXSINP-INDIVID(1:RXSINP-LGTH)
* WS-UNICODE-CCSID
* )
* DELIMITED BY SIZE INTO UNICODE-UTF-16-STRING
* POINTER YY
* SUBTRACT 1 FROM YY
* MOVE FUNCTION DISPLAY-OF (
* UNICODE-UTF-16-STRING(1:RXSINP-LGTH)
* WS-EBCDIC-CCSID
* )
* TO DISPLAY-STRING(1:YY)
IF YY > 0
MOVE YY TO RXSOUTP-LGTH
MOVE RXSOUTP-LGTH TO WSRXSOUTP-LGTH
MOVE DISPLAY-STRING(1:YY)
TO RXSOUTP-INDIVID(1:RXSOUTP-LGTH)
WRITE RXSOUTP-INDIVID
END-IF
.
CONVERT-FROM-UTF-8-EX.
EXIT.
CONVERT-TO-UTF-8 SECTION.
MOVE FUNCTION NATIONAL-OF (
RXSINP-INDIVID(1:RXSINP-LGTH)
WS-EBCDIC-CCSID
)
TO UNICODE-UTF-16-STRING
MOVE 1 TO XX
STRING FUNCTION DISPLAY-OF (
UNICODE-UTF-16-STRING(1:RXSINP-LGTH)
WS-UNICODE-CCSID
)
DELIMITED BY SIZE
INTO UTF-8-STRING
POINTER XX
SUBTRACT 1 FROM XX
EVALUATE TRUE
WHEN XX > 8000
MOVE 8000 TO RXSOUTP-LGTH
MOVE RXSOUTP-LGTH TO WSRXSOUTP-LGTH
MOVE UTF-8-STRING(1:8000)
TO RXSOUTP-INDIVID(1:RXSOUTP-LGTH)
WRITE RXSOUTP-INDIVID
SUBTRACT 8000 FROM XX
MOVE XX TO RXSOUTP-LGTH
MOVE RXSOUTP-LGTH TO WSRXSOUTP-LGTH
MOVE UTF-8-STRING(8001:XX)
TO RXSOUTP-INDIVID(1:RXSOUTP-LGTH)
WRITE RXSOUTP-INDIVID
WHEN XX = 0
CONTINUE
WHEN ANY
MOVE XX TO RXSOUTP-LGTH
MOVE RXSOUTP-LGTH TO WSRXSOUTP-LGTH
MOVE UTF-8-STRING(1:XX)
TO RXSOUTP-INDIVID(1:RXSOUTP-LGTH)
WRITE RXSOUTP-INDIVID
END-EVALUATE
.
CONVERT-TO-UTF-8-EX.
EXIT.
CONVERT-FROM-ASCII SECTION.
MOVE RXSINP-LGTH TO RXSOUTP-LGTH
MOVE RXSOUTP-LGTH TO WSRXSOUTP-LGTH
MOVE FUNCTION DISPLAY-OF (
FUNCTION NATIONAL-OF (
RXSINP-INDIVID(1:RXSINP-LGTH)
WS-ASCII-CCSID
)
WS-EBCDIC-CCSID
)
TO RXSOUTP-INDIVID(1:RXSOUTP-LGTH)
WRITE RXSOUTP-INDIVID
.
CONVERT-FROM-ASCII-EX.
EXIT.
END PROGRAM RXSCONV.
IDENTIFICATION DIVISION.
PROGRAM-ID. FRAUTF8 COMMON.
* konverter fra utf-8:
* Hvis sidste char er 'shift out' x'C3', så tages
* denne ikke med i konverteringen
* men gemmes til næste gang
*
DATA DIVISION.
WORKING-STORAGE SECTION.
01 LIBRATID PIC X(24) LIBRATID
VALUE 'LIBRATIDLIBRATIDLIBRATID'. LIBRATID
01 FILLER REDEFINES LIBRATID. LIBRATID
02 LT-PGMID-DTO-VERSION. LIBRATID
03 LT-PGMID PIC X(8). LIBRATID
03 LT-DTO-VERSION. LIBRATID
04 LT-DTO PIC X(6). LIBRATID
04 LT-VERSION PIC X(2). LIBRATID
02 LT-TID PIC X(8). LIBRATID
01 WS-UNICODE-CCSID PIC 9(4) COMP VALUE 1208.
01 WS-EBCDIC-CCSID PIC 9(4) COMP VALUE 1142.
01 UNICODE-UTF-16-STRING-G.
02 UNICODE-UTF-16-STRING PIC N(8100) USAGE NATIONAL.
01 UTF8-REST-LGD PIC S9(9) COMP.
01 UTF8-REST-STRENG PIC X(100).
01 WS-STRENG PIC X(8100).
01 WS-LGD PIC S9(8) COMP.
01 START-SW PIC X VALUE '1'.
01 UTF8-LGD PIC S9(8) COMP.
01 UTF8-STRENG PIC X(8000).
01 WS-LGD-9 PIC 9.
01 WS-LAEST-SW PIC X.
LINKAGE SECTION.
01 LINK-UTF8-STRENG PIC X(8000).
01 LINK-UTF8-LGD PIC S9(8) COMP.
01 LINK-EBCDIC-STRENG PIC X(8000).
01 LINK-EBCDIC-LGD PIC S9(8) COMP.
01 LINK-EBCDIC-CCSID PIC 9(4) COMP.
PROCEDURE DIVISION USING
LINK-UTF8-STRENG
LINK-UTF8-LGD
LINK-EBCDIC-STRENG
LINK-EBCDIC-LGD
LINK-EBCDIC-CCSID
.
MOVE LINK-UTF8-LGD TO UTF8-LGD
MOVE LINK-UTF8-STRENG(1:LINK-UTF8-LGD)
TO UTF8-STRENG(1:UTF8-LGD)
IF UTF8-REST-LGD > 0
MOVE 1 TO WS-LGD
STRING UTF8-REST-STRENG(1:UTF8-REST-LGD)
UTF8-STRENG(1:UTF8-LGD)
DELIMITED BY SIZE INTO WS-STRENG
POINTER WS-LGD
COMPUTE UTF8-LGD = WS-LGD - 1
MOVE WS-STRENG(1:UTF8-LGD)
TO UTF8-STRENG(1:UTF8-LGD)
MOVE ZERO TO UTF8-REST-LGD
END-IF
* 2015-03-11: undersøgelsen giver ikke mening for korte strenge:
IF UTF8-LGD > 3
EVALUATE TRUE
WHEN UTF8-STRENG(UTF8-LGD:1) IS UTF8-TWO-BYTE
WHEN UTF8-STRENG(UTF8-LGD:1) IS UTF8-THREE-BYTE
WHEN UTF8-STRENG(UTF8-LGD:1) IS UTF8-FOUR-BYTE
MOVE UTF8-STRENG(UTF8-LGD:1)
TO UTF8-REST-STRENG(1:1)
MOVE 1 TO UTF8-REST-LGD
SUBTRACT 1 FROM UTF8-LGD
WHEN UTF8-STRENG(UTF8-LGD - 1:1) IS UTF8-THREE-BYTE
WHEN UTF8-STRENG(UTF8-LGD - 1:1) IS UTF8-FOUR-BYTE
MOVE UTF8-STRENG(UTF8-LGD - 1:2)
TO UTF8-REST-STRENG(1:2)
MOVE 2 TO UTF8-REST-LGD
SUBTRACT 2 FROM UTF8-LGD
WHEN UTF8-STRENG(UTF8-LGD - 2:1) IS UTF8-FOUR-BYTE
MOVE UTF8-STRENG(UTF8-LGD - 2:3)
TO UTF8-REST-STRENG(1:3)
MOVE 3 TO UTF8-REST-LGD
SUBTRACT 3 FROM UTF8-LGD
END-EVALUATE
END-IF
MOVE 1 TO LINK-EBCDIC-LGD
STRING FUNCTION NATIONAL-OF (
UTF8-STRENG(1:UTF8-LGD)
WS-UNICODE-CCSID
)
DELIMITED BY SIZE INTO UNICODE-UTF-16-STRING
POINTER LINK-EBCDIC-LGD
SUBTRACT 1 FROM LINK-EBCDIC-LGD
MOVE FUNCTION DISPLAY-OF (
UNICODE-UTF-16-STRING(1:UTF8-LGD)
LINK-EBCDIC-CCSID
)
TO LINK-EBCDIC-STRENG(1:LINK-EBCDIC-LGD)
GOBACK.
END PROGRAM FRAUTF8.
* ****** **** **** ********
* ******* *** *** *********
* * *** ****** **
* ****** **** ********
* **** **** ********
* * *** ****** **
* * *** *** *** *********
* * ******** **** ******** GENERERET FRA XEJLUDTX
IDENTIFICATION DIVISION.
PROGRAM-ID. FEJLUDTX COMMON.
*
* FIND DIV IBM-FEJLTEKSTER SDBSTEST.SLUTSTND.LIBRA
*
DATA DIVISION.
WORKING-STORAGE SECTION.
01 LIBRATID PIC X(24) LIBRATID
VALUE 'LIBRATIDLIBRATIDLIBRATID'. LIBRATID
01 FILLER REDEFINES LIBRATID. LIBRATID
02 LT-PGMID-DTO-VERSION. LIBRATID
03 LT-PGMID PIC X(8). LIBRATID
03 LT-DTO-VERSION. LIBRATID
04 LT-DTO PIC X(6). LIBRATID
04 LT-VERSION PIC X(2). LIBRATID
02 LT-TID PIC X(8). LIBRATID
01 XML-DECODE.
02 RTN PIC 9(2) COMP.
02 RSN PIC 9(4) COMP-5.
01 HV PIC X(16) VALUE '0123456789ABCDEF'.
01 RTN-DISPL PIC 99.
LINKAGE SECTION.
01 LINK-REASON PIC S9(9) COMP.
01 LINK-DOMAIN PIC X(8).
01 LINK-TEKST PIC X(200).
PROCEDURE DIVISION USING
LINK-DOMAIN
LINK-REASON
LINK-TEKST
.
MOVE SPACES TO LINK-TEKST
EVALUATE TRUE
WHEN LINK-DOMAIN(1:2) ='MQ'
IF LINK-TEKST = SPACES
EVALUATE LINK-REASON
WHEN 0
MOVE 'NONE'
TO LINK-TEKST
WHEN 900
MOVE 'APPL-FIRST'
TO LINK-TEKST
WHEN 999
MOVE 'APPL-LAST'
TO LINK-TEKST
WHEN 2001
MOVE 'ALIAS-BASE-Q-TYPE-ERROR'
TO LINK-TEKST
WHEN 2002
MOVE 'ALREADY-CONNECTED'
TO LINK-TEKST
WHEN 2003
MOVE 'BACKED-OUT'
TO LINK-TEKST
WHEN 2004
MOVE 'BUFFER-ERROR'
TO LINK-TEKST
WHEN 2005
MOVE 'BUFFER-LENGTH-ERROR'
TO LINK-TEKST
WHEN 2006
MOVE 'CHAR-ATTR-LENGTH-ERROR'
TO LINK-TEKST
WHEN 2007
MOVE 'CHAR-ATTRS-ERROR'
TO LINK-TEKST
WHEN 2008
MOVE 'CHAR-ATTRS-TOO-SHORT'
TO LINK-TEKST
WHEN 2009
MOVE 'CONNECTION-BROKEN'
TO LINK-TEKST
WHEN 2010
MOVE 'DATA-LENGTH-ERROR'
TO LINK-TEKST
WHEN 2011
MOVE 'DYNAMIC-Q-NAME-ERROR'
TO LINK-TEKST
WHEN 2012
MOVE 'ENVIRONMENT-ERROR'
TO LINK-TEKST
WHEN 2013
MOVE 'EXPIRY-ERROR'
TO LINK-TEKST
WHEN 2014
MOVE 'FEEDBACK-ERROR'
TO LINK-TEKST
WHEN 2016
MOVE 'GET-INHIBITED'
TO LINK-TEKST
WHEN 2017
MOVE 'HANDLE-NOT-AVAILABLE'
TO LINK-TEKST
WHEN 2018
MOVE 'HCONN-ERROR'
TO LINK-TEKST
WHEN 2019
MOVE 'HOBJ-ERROR'
TO LINK-TEKST
WHEN 2020
MOVE 'INHIBIT-VALUE-ERROR'
TO LINK-TEKST
WHEN 2021
MOVE 'INT-ATTR-COUNT-ERROR'
TO LINK-TEKST
WHEN 2022
MOVE 'INT-ATTR-COUNT-TOO-SMALL'
TO LINK-TEKST
WHEN 2023
MOVE 'INT-ATTRS-ARRAY-ERROR'
TO LINK-TEKST
WHEN 2024
MOVE 'SYNCPOINT-LIMIT-REACHED'
TO LINK-TEKST
WHEN 2025
MOVE 'MAX-CONNS-LIMIT-REACHED'
TO LINK-TEKST
WHEN 2026
MOVE 'MD-ERROR'
TO LINK-TEKST
WHEN 2027
MOVE 'MISSING-REPLY-TO-Q'
TO LINK-TEKST
WHEN 2029
MOVE 'MSG-TYPE-ERROR'
TO LINK-TEKST
WHEN 2030
MOVE 'MSG-TOO-BIG-FOR-Q'
TO LINK-TEKST
WHEN 2031
MOVE 'MSG-TOO-BIG-FOR-Q-MGR'
TO LINK-TEKST
WHEN 2033
MOVE 'NO-MSG-AVAILABLE'
TO LINK-TEKST
WHEN 2034
MOVE 'NO-MSG-UNDER-CURSOR'
TO LINK-TEKST
WHEN 2035
MOVE 'NOT-AUTHORIZED'
TO LINK-TEKST
WHEN 2036
MOVE 'NOT-OPEN-FOR-BROWSE'
TO LINK-TEKST
WHEN 2037
MOVE 'NOT-OPEN-FOR-INPUT'
TO LINK-TEKST
WHEN 2038
MOVE 'NOT-OPEN-FOR-INQUIRE'
TO LINK-TEKST
WHEN 2039
MOVE 'NOT-OPEN-FOR-OUTPUT'
TO LINK-TEKST
WHEN 2040
MOVE 'NOT-OPEN-FOR-SET'
TO LINK-TEKST
WHEN 2041
MOVE 'OBJECT-CHANGED'
TO LINK-TEKST
WHEN 2042
MOVE 'OBJECT-IN-USE'
TO LINK-TEKST
WHEN 2043
MOVE 'OBJECT-TYPE-ERROR'
TO LINK-TEKST
WHEN 2044
MOVE 'OD-ERROR'
TO LINK-TEKST
WHEN 2045
MOVE 'OPTION-NOT-VALID-FOR-TYPE'
TO LINK-TEKST
WHEN 2046
MOVE 'OPTIONS-ERROR'
TO LINK-TEKST
WHEN 2047
MOVE 'PERSISTENCE-ERROR'
TO LINK-TEKST
WHEN 2048
MOVE 'PERSISTENT-NOT-ALLOWED'
TO LINK-TEKST
WHEN 2049
MOVE 'PRIORITY-EXCEEDS-MAXIMUM'
TO LINK-TEKST
WHEN 2050
MOVE 'PRIORITY-ERROR'
TO LINK-TEKST
WHEN 2051
MOVE 'PUT-INHIBITED'
TO LINK-TEKST
WHEN 2052
MOVE 'Q-DELETED'
TO LINK-TEKST
WHEN 2053
MOVE 'Q-FULL'
TO LINK-TEKST
WHEN 2055
MOVE 'Q-NOT-EMPTY'
TO LINK-TEKST
WHEN 2056
MOVE 'Q-SPACE-NOT-AVAILABLE'
TO LINK-TEKST
WHEN 2057
MOVE 'Q-TYPE-ERROR'
TO LINK-TEKST
WHEN 2058
MOVE 'Q-MGR-NAME-ERROR'
TO LINK-TEKST
WHEN 2059
MOVE 'Q-MGR-NOT-AVAILABLE'
TO LINK-TEKST
WHEN 2061
MOVE 'REPORT-OPTIONS-ERROR'
TO LINK-TEKST
WHEN 2062
MOVE 'SECOND-MARK-NOT-ALLOWED'
TO LINK-TEKST
WHEN 2063
MOVE 'SECURITY-ERROR'
TO LINK-TEKST
WHEN 2065
MOVE 'SELECTOR-COUNT-ERROR'
TO LINK-TEKST
WHEN 2066
MOVE 'SELECTOR-LIMIT-EXCEEDED'
TO LINK-TEKST
WHEN 2067
MOVE 'SELECTOR-ERROR'
TO LINK-TEKST
WHEN 2068
MOVE 'SELECTOR-NOT-FOR-TYPE'
TO LINK-TEKST
WHEN 2069
MOVE 'SIGNAL-OUTSTANDING'
TO LINK-TEKST
WHEN 2070
MOVE 'SIGNAL-REQUEST-ACCEPTED'
TO LINK-TEKST
WHEN 2071
MOVE 'STORAGE-NOT-AVAILABLE'
TO LINK-TEKST
WHEN 2072
MOVE 'SYNCPOINT-NOT-AVAILABLE'
TO LINK-TEKST
WHEN 2075
MOVE 'TRIGGER-CONTROL-ERROR'
TO LINK-TEKST
WHEN 2076
MOVE 'TRIGGER-DEPTH-ERROR'
TO LINK-TEKST
WHEN 2077
MOVE 'TRIGGER-MSG-PRIORITY-ERR'
TO LINK-TEKST
WHEN 2078
MOVE 'TRIGGER-TYPE-ERROR'
TO LINK-TEKST
WHEN 2079
MOVE 'TRUNCATED-MSG-ACCEPTED'
TO LINK-TEKST
WHEN 2080
MOVE 'TRUNCATED-MSG-FAILED'
TO LINK-TEKST
WHEN 2082
MOVE 'UNKNOWN-ALIAS-BASE-Q'
TO LINK-TEKST
WHEN 2085
MOVE 'UNKNOWN-OBJECT-NAME'
TO LINK-TEKST
WHEN 2086
MOVE 'UNKNOWN-OBJECT-Q-MGR'
TO LINK-TEKST
WHEN 2087
MOVE 'UNKNOWN-REMOTE-Q-MGR'
TO LINK-TEKST
WHEN 2090
MOVE 'WAIT-INTERVAL-ERROR'
TO LINK-TEKST
WHEN 2091
MOVE 'XMIT-Q-TYPE-ERROR'
TO LINK-TEKST
WHEN 2092
MOVE 'XMIT-Q-USAGE-ERROR'
TO LINK-TEKST
WHEN 2093
MOVE 'NOT-OPEN-FOR-PASS-ALL'
TO LINK-TEKST
WHEN 2094
MOVE 'NOT-OPEN-FOR-PASS-IDENT'
TO LINK-TEKST
WHEN 2095
MOVE 'NOT-OPEN-FOR-SET-ALL'
TO LINK-TEKST
WHEN 2096
MOVE 'NOT-OPEN-FOR-SET-IDENT'
TO LINK-TEKST
WHEN 2097
MOVE 'CONTEXT-HANDLE-ERROR'
TO LINK-TEKST
WHEN 2098
MOVE 'CONTEXT-NOT-AVAILABLE'
TO LINK-TEKST
WHEN 2099
MOVE 'SIGNAL1-ERROR'
TO LINK-TEKST
WHEN 2100
MOVE 'OBJECT-ALREADY-EXISTS'
TO LINK-TEKST
WHEN 2101
MOVE 'OBJECT-DAMAGED'
TO LINK-TEKST
WHEN 2102
MOVE 'RESOURCE-PROBLEM'
TO LINK-TEKST
WHEN 2103
MOVE 'ANOTHER-Q-MGR-CONNECTED'
TO LINK-TEKST
WHEN 2104
MOVE 'UNKNOWN-REPORT-OPTION'
TO LINK-TEKST
WHEN 2105
MOVE 'STORAGE-CLASS-ERROR'
TO LINK-TEKST
WHEN 2106
MOVE 'COD-NOT-VALID-FOR-XCF-Q'
TO LINK-TEKST
WHEN 2107
MOVE 'XWAIT-CANCELED'
TO LINK-TEKST
WHEN 2108
MOVE 'XWAIT-ERROR'
TO LINK-TEKST
WHEN 2109
MOVE 'SUPPRESSED-BY-EXIT'
TO LINK-TEKST
WHEN 2110
MOVE 'FORMAT-ERROR'
TO LINK-TEKST
WHEN 2111
MOVE 'SOURCE-CCSID-ERROR'
TO LINK-TEKST
WHEN 2112
MOVE 'SOURCE-INTEGER-ENC-ERROR'
TO LINK-TEKST
WHEN 2113
MOVE 'SOURCE-DECIMAL-ENC-ERROR'
TO LINK-TEKST
WHEN 2114
MOVE 'SOURCE-FLOAT-ENC-ERROR'
TO LINK-TEKST
WHEN 2115
MOVE 'TARGET-CCSID-ERROR'
TO LINK-TEKST
WHEN 2116
MOVE 'TARGET-INTEGER-ENC-ERROR'
TO LINK-TEKST
WHEN 2117
MOVE 'TARGET-DECIMAL-ENC-ERROR'
TO LINK-TEKST
WHEN 2118
MOVE 'TARGET-FLOAT-ENC-ERROR'
TO LINK-TEKST
WHEN 2119
MOVE 'NOT-CONVERTED'
TO LINK-TEKST
WHEN 2120
MOVE 'CONVERTED-MSG-TOO-BIG'
TO LINK-TEKST
WHEN 2120
MOVE 'TRUNCATED'
TO LINK-TEKST
WHEN 2121
MOVE 'NO-EXTERNAL-PARTICIPANTS'
TO LINK-TEKST
WHEN 2122
MOVE 'PARTICIPANT-NOT-AVAILABLE'
TO LINK-TEKST
WHEN 2123
MOVE 'OUTCOME-MIXED'
TO LINK-TEKST
WHEN 2124
MOVE 'OUTCOME-PENDING'
TO LINK-TEKST
WHEN 2125
MOVE 'BRIDGE-STARTED'
TO LINK-TEKST
WHEN 2126
MOVE 'BRIDGE-STOPPED'
TO LINK-TEKST
WHEN 2127
MOVE 'ADAPTER-STORAGE-SHORTAGE'
TO LINK-TEKST
WHEN 2128
MOVE 'UOW-IN-PROGRESS'
TO LINK-TEKST
WHEN 2129
MOVE 'ADAPTER-CONN-LOAD-ERROR'
TO LINK-TEKST
WHEN 2130
MOVE 'ADAPTER-SERV-LOAD-ERROR'
TO LINK-TEKST
WHEN 2131
MOVE 'ADAPTER-DEFS-ERROR'
TO LINK-TEKST
WHEN 2132
MOVE 'ADAPTER-DEFS-LOAD-ERROR'
TO LINK-TEKST
WHEN 2133
MOVE 'ADAPTER-CONV-LOAD-ERROR'
TO LINK-TEKST
WHEN 2134
MOVE 'BO-ERROR'
TO LINK-TEKST
WHEN 2135
MOVE 'DH-ERROR'
TO LINK-TEKST
WHEN 2136
MOVE 'MULTIPLE-REASONS'
TO LINK-TEKST
WHEN 2137
MOVE 'OPEN-FAILED'
TO LINK-TEKST
WHEN 2138
MOVE 'ADAPTER-DISC-LOAD-ERROR'
TO LINK-TEKST
WHEN 2139
MOVE 'CNO-ERROR'
TO LINK-TEKST
WHEN 2140
MOVE 'CICS-WAIT-FAILED'
TO LINK-TEKST
WHEN 2141
MOVE 'DLH-ERROR'
TO LINK-TEKST
WHEN 2142
MOVE 'HEADER-ERROR'
TO LINK-TEKST
WHEN 2143
MOVE 'SOURCE-LENGTH-ERROR'
TO LINK-TEKST
WHEN 2144
MOVE 'TARGET-LENGTH-ERROR'
TO LINK-TEKST
WHEN 2145
MOVE 'SOURCE-BUFFER-ERROR'
TO LINK-TEKST
WHEN 2146
MOVE 'TARGET-BUFFER-ERROR'
TO LINK-TEKST
WHEN 2148
MOVE 'IIH-ERROR'
TO LINK-TEKST
WHEN 2149
MOVE 'PCF-ERROR'
TO LINK-TEKST
WHEN 2150
MOVE 'DBCS-ERROR'
TO LINK-TEKST
WHEN 2152
MOVE 'OBJECT-NAME-ERROR'
TO LINK-TEKST
WHEN 2153
MOVE 'OBJECT-Q-MGR-NAME-ERROR'
TO LINK-TEKST
WHEN 2154
MOVE 'RECS-PRESENT-ERROR'
TO LINK-TEKST
WHEN 2155
MOVE 'OBJECT-RECORDS-ERROR'
TO LINK-TEKST
WHEN 2156
MOVE 'RESPONSE-RECORDS-ERROR'
TO LINK-TEKST
WHEN 2157
MOVE 'ASID-MISMATCH'
TO LINK-TEKST
WHEN 2158
MOVE 'PMO-RECORD-FLAGS-ERROR'
TO LINK-TEKST
WHEN 2159
MOVE 'PUT-MSG-RECORDS-ERROR'
TO LINK-TEKST
WHEN 2160
MOVE 'CONN-ID-IN-USE'
TO LINK-TEKST
WHEN 2161
MOVE 'Q-MGR-QUIESCING'
TO LINK-TEKST
WHEN 2162
MOVE 'Q-MGR-STOPPING'
TO LINK-TEKST
WHEN 2163
MOVE 'DUPLICATE-RECOV-COORD'
TO LINK-TEKST
WHEN 2173
MOVE 'PMO-ERROR'
TO LINK-TEKST
WHEN 2182
MOVE 'API-EXIT-NOT-FOUND'
TO LINK-TEKST
WHEN 2183
MOVE 'API-EXIT-LOAD-ERROR'
TO LINK-TEKST
WHEN 2184
MOVE 'REMOTE-Q-NAME-ERROR'
TO LINK-TEKST
WHEN 2185
MOVE 'INCONSISTENT-PERSISTENCE'
TO LINK-TEKST
WHEN 2186
MOVE 'GMO-ERROR'
TO LINK-TEKST
WHEN 2187
MOVE 'CICS-BRIDGE-RESTRICTION'
TO LINK-TEKST
WHEN 2188
MOVE 'STOPPED-BY-CLUSTER-EXIT'
TO LINK-TEKST
WHEN 2189
MOVE 'CLUSTER-RESOLUTION-ERROR'
TO LINK-TEKST
WHEN 2190
MOVE 'CONVERTED-STRING-TOO-BIG'
TO LINK-TEKST
WHEN 2191
MOVE 'TMC-ERROR'
TO LINK-TEKST
WHEN 2192
MOVE 'PAGESET-FULL'
TO LINK-TEKST
WHEN 2192
MOVE 'STORAGE-MEDIUM-FULL'
TO LINK-TEKST
WHEN 2193
MOVE 'PAGESET-ERROR'
TO LINK-TEKST
WHEN 2194
MOVE 'NAME-NOT-VALID-FOR-TYPE'
TO LINK-TEKST
WHEN 2195
MOVE 'UNEXPECTED-ERROR'
TO LINK-TEKST
WHEN 2196
MOVE 'UNKNOWN-XMIT-Q'
TO LINK-TEKST
WHEN 2197
MOVE 'UNKNOWN-DEF-XMIT-Q'
TO LINK-TEKST
WHEN 2198
MOVE 'DEF-XMIT-Q-TYPE-ERROR'
TO LINK-TEKST
WHEN 2199
MOVE 'DEF-XMIT-Q-USAGE-ERROR'
TO LINK-TEKST
WHEN 2201
MOVE 'NAME-IN-USE'
TO LINK-TEKST
WHEN 2202
MOVE 'CONNECTION-QUIESCING'
TO LINK-TEKST
WHEN 2203
MOVE 'CONNECTION-STOPPING'
TO LINK-TEKST
WHEN 2204
MOVE 'ADAPTER-NOT-AVAILABLE'
TO LINK-TEKST
WHEN 2206
MOVE 'MSG-ID-ERROR'
TO LINK-TEKST
WHEN 2207
MOVE 'CORREL-ID-ERROR'
TO LINK-TEKST
WHEN 2208
MOVE 'FILE-SYSTEM-ERROR'
TO LINK-TEKST
WHEN 2209
MOVE 'NO-MSG-LOCKED'
TO LINK-TEKST
WHEN 2210
MOVE 'SOAP-DOTNET-ERROR'
TO LINK-TEKST
WHEN 2211
MOVE 'SOAP-AXIS-ERROR'
TO LINK-TEKST
WHEN 2212
MOVE 'SOAP-URL-ERROR'
TO LINK-TEKST
WHEN 2216
MOVE 'FILE-NOT-AUDITED'
TO LINK-TEKST
WHEN 2217
MOVE 'CONNECTION-NOT-AUTHORIZED'
TO LINK-TEKST
WHEN 2218
MOVE 'MSG-TOO-BIG-FOR-CHANNEL'
TO LINK-TEKST
WHEN 2219
MOVE 'CALL-IN-PROGRESS'
TO LINK-TEKST
WHEN 2220
MOVE 'RMH-ERROR'
TO LINK-TEKST
WHEN 2222
MOVE 'Q-MGR-ACTIVE'
TO LINK-TEKST
WHEN 2223
MOVE 'Q-MGR-NOT-ACTIVE'
TO LINK-TEKST
WHEN 2224
MOVE 'Q-DEPTH-HIGH'
TO LINK-TEKST
WHEN 2225
MOVE 'Q-DEPTH-LOW'
TO LINK-TEKST
WHEN 2226
MOVE 'Q-SERVICE-INTERVAL-HIGH'
TO LINK-TEKST
WHEN 2227
MOVE 'Q-SERVICE-INTERVAL-OK'
TO LINK-TEKST
WHEN 2228
MOVE 'RFH-HEADER-FIELD-ERROR'
TO LINK-TEKST
WHEN 2229
MOVE 'RAS-PROPERTY-ERROR'
TO LINK-TEKST
WHEN 2232
MOVE 'UNIT-OF-WORK-NOT-STARTED'
TO LINK-TEKST
WHEN 2233
MOVE 'CHANNEL-AUTO-DEF-OK'
TO LINK-TEKST
WHEN 2234
MOVE 'CHANNEL-AUTO-DEF-ERROR'
TO LINK-TEKST
WHEN 2235
MOVE 'CFH-ERROR'
TO LINK-TEKST
WHEN 2236
MOVE 'CFIL-ERROR'
TO LINK-TEKST
WHEN 2237
MOVE 'CFIN-ERROR'
TO LINK-TEKST
WHEN 2238
MOVE 'CFSL-ERROR'
TO LINK-TEKST
WHEN 2239
MOVE 'CFST-ERROR'
TO LINK-TEKST
WHEN 2241
MOVE 'INCOMPLETE-GROUP'
TO LINK-TEKST
WHEN 2242
MOVE 'INCOMPLETE-MSG'
TO LINK-TEKST
WHEN 2243
MOVE 'INCONSISTENT-CCSIDS'
TO LINK-TEKST
WHEN 2244
MOVE 'INCONSISTENT-ENCODINGS'
TO LINK-TEKST
WHEN 2245
MOVE 'INCONSISTENT-UOW'
TO LINK-TEKST
WHEN 2246
MOVE 'INVALID-MSG-UNDER-CURSOR'
TO LINK-TEKST
WHEN 2247
MOVE 'MATCH-OPTIONS-ERROR'
TO LINK-TEKST
WHEN 2248
MOVE 'MDE-ERROR'
TO LINK-TEKST
WHEN 2249
MOVE 'MSG-FLAGS-ERROR'
TO LINK-TEKST
WHEN 2250
MOVE 'MSG-SEQ-NUMBER-ERROR'
TO LINK-TEKST
WHEN 2251
MOVE 'OFFSET-ERROR'
TO LINK-TEKST
WHEN 2252
MOVE 'ORIGINAL-LENGTH-ERROR'
TO LINK-TEKST
WHEN 2253
MOVE 'SEGMENT-LENGTH-ZERO'
TO LINK-TEKST
WHEN 2255
MOVE 'UOW-NOT-AVAILABLE'
TO LINK-TEKST
WHEN 2256
MOVE 'WRONG-GMO-VERSION'
TO LINK-TEKST
WHEN 2257
MOVE 'WRONG-MD-VERSION'
TO LINK-TEKST
WHEN 2258
MOVE 'GROUP-ID-ERROR'
TO LINK-TEKST
WHEN 2259
MOVE 'INCONSISTENT-BROWSE'
TO LINK-TEKST
WHEN 2260
MOVE 'XQH-ERROR'
TO LINK-TEKST
WHEN 2261
MOVE 'SRC-ENV-ERROR'
TO LINK-TEKST
WHEN 2262
MOVE 'SRC-NAME-ERROR'
TO LINK-TEKST
WHEN 2263
MOVE 'DEST-ENV-ERROR'
TO LINK-TEKST
WHEN 2264
MOVE 'DEST-NAME-ERROR'
TO LINK-TEKST
WHEN 2265
MOVE 'TM-ERROR'
TO LINK-TEKST
WHEN 2266
MOVE 'CLUSTER-EXIT-ERROR'
TO LINK-TEKST
WHEN 2267
MOVE 'CLUSTER-EXIT-LOAD-ERROR'
TO LINK-TEKST
WHEN 2268
MOVE 'CLUSTER-PUT-INHIBITED'
TO LINK-TEKST
WHEN 2269
MOVE 'CLUSTER-RESOURCE-ERROR'
TO LINK-TEKST
WHEN 2270
MOVE 'NO-DESTINATIONS-AVAILABLE'
TO LINK-TEKST
WHEN 2271
MOVE 'CONN-TAG-IN-USE'
TO LINK-TEKST
WHEN 2272
MOVE 'PARTIALLY-CONVERTED'
TO LINK-TEKST
WHEN 2273
MOVE 'CONNECTION-ERROR'
TO LINK-TEKST
WHEN 2274
MOVE 'OPTION-ENVIRONMENT-ERROR'
TO LINK-TEKST
WHEN 2277
MOVE 'CD-ERROR'
TO LINK-TEKST
WHEN 2278
MOVE 'CLIENT-CONN-ERROR'
TO LINK-TEKST
WHEN 2279
MOVE 'CHANNEL-STOPPED-BY-USER'
TO LINK-TEKST
WHEN 2280
MOVE 'HCONFIG-ERROR'
TO LINK-TEKST
WHEN 2281
MOVE 'FUNCTION-ERROR'
TO LINK-TEKST
WHEN 2282
MOVE 'CHANNEL-STARTED'
TO LINK-TEKST
WHEN 2283
MOVE 'CHANNEL-STOPPED'
TO LINK-TEKST
WHEN 2284
MOVE 'CHANNEL-CONV-ERROR'
TO LINK-TEKST
WHEN 2285
MOVE 'SERVICE-NOT-AVAILABLE'
TO LINK-TEKST
WHEN 2286
MOVE 'INITIALIZATION-FAILED'
TO LINK-TEKST
WHEN 2287
MOVE 'TERMINATION-FAILED'
TO LINK-TEKST
WHEN 2288
MOVE 'UNKNOWN-Q-NAME'
TO LINK-TEKST
WHEN 2289
MOVE 'SERVICE-ERROR'
TO LINK-TEKST
END-EVALUATE
END-IF
IF LINK-TEKST = SPACES
EVALUATE LINK-REASON
WHEN 2290
MOVE 'Q-ALREADY-EXISTS'
TO LINK-TEKST
WHEN 2291
MOVE 'USER-ID-NOT-AVAILABLE'
TO LINK-TEKST
WHEN 2292
MOVE 'UNKNOWN-ENTITY'
TO LINK-TEKST
WHEN 2293
MOVE 'UNKNOWN-AUTH-ENTITY'
TO LINK-TEKST
WHEN 2294
MOVE 'UNKNOWN-REF-OBJECT'
TO LINK-TEKST
WHEN 2295
MOVE 'CHANNEL-ACTIVATED'
TO LINK-TEKST
WHEN 2296
MOVE 'CHANNEL-NOT-ACTIVATED'
TO LINK-TEKST
WHEN 2297
MOVE 'UOW-CANCELED'
TO LINK-TEKST
WHEN 2298
MOVE 'FUNCTION-NOT-SUPPORTED'
TO LINK-TEKST
WHEN 2299
MOVE 'SELECTOR-TYPE-ERROR'
TO LINK-TEKST
WHEN 2300
MOVE 'COMMAND-TYPE-ERROR'
TO LINK-TEKST
WHEN 2301
MOVE 'MULTIPLE-INSTANCE-ERROR'
TO LINK-TEKST
WHEN 2302
MOVE 'SYSTEM-ITEM-NOT-ALTERABLE'
TO LINK-TEKST
WHEN 2303
MOVE 'BAG-CONVERSION-ERROR'
TO LINK-TEKST
WHEN 2304
MOVE 'SELECTOR-OUT-OF-RANGE'
TO LINK-TEKST
WHEN 2305
MOVE 'SELECTOR-NOT-UNIQUE'
TO LINK-TEKST
WHEN 2306
MOVE 'INDEX-NOT-PRESENT'
TO LINK-TEKST
WHEN 2307
MOVE 'STRING-ERROR'
TO LINK-TEKST
WHEN 2308
MOVE 'ENCODING-NOT-SUPPORTED'
TO LINK-TEKST
WHEN 2309
MOVE 'SELECTOR-NOT-PRESENT'
TO LINK-TEKST
WHEN 2310
MOVE 'OUT-SELECTOR-ERROR'
TO LINK-TEKST
WHEN 2311
MOVE 'STRING-TRUNCATED'
TO LINK-TEKST
WHEN 2312
MOVE 'SELECTOR-WRONG-TYPE'
TO LINK-TEKST
WHEN 2313
MOVE 'INCONSISTENT-ITEM-TYPE'
TO LINK-TEKST
WHEN 2314
MOVE 'INDEX-ERROR'
TO LINK-TEKST
WHEN 2315
MOVE 'SYSTEM-BAG-NOT-ALTERABLE'
TO LINK-TEKST
WHEN 2316
MOVE 'ITEM-COUNT-ERROR'
TO LINK-TEKST
WHEN 2317
MOVE 'FORMAT-NOT-SUPPORTED'
TO LINK-TEKST
WHEN 2318
MOVE 'SELECTOR-NOT-SUPPORTED'
TO LINK-TEKST
WHEN 2319
MOVE 'ITEM-VALUE-ERROR'
TO LINK-TEKST
WHEN 2320
MOVE 'HBAG-ERROR'
TO LINK-TEKST
WHEN 2321
MOVE 'PARAMETER-MISSING'
TO LINK-TEKST
WHEN 2322
MOVE 'CMD-SERVER-NOT-AVAILABLE'
TO LINK-TEKST
WHEN 2323
MOVE 'STRING-LENGTH-ERROR'
TO LINK-TEKST
WHEN 2324
MOVE 'INQUIRY-COMMAND-ERROR'
TO LINK-TEKST
WHEN 2325
MOVE 'NESTED-BAG-NOT-SUPPORTED'
TO LINK-TEKST
WHEN 2326
MOVE 'BAG-WRONG-TYPE'
TO LINK-TEKST
WHEN 2327
MOVE 'ITEM-TYPE-ERROR'
TO LINK-TEKST
WHEN 2328
MOVE 'SYSTEM-BAG-NOT-DELETABLE'
TO LINK-TEKST
WHEN 2329
MOVE 'SYSTEM-ITEM-NOT-DELETABLE'
TO LINK-TEKST
WHEN 2330
MOVE 'CODED-CHAR-SET-ID-ERROR'
TO LINK-TEKST
WHEN 2331
MOVE 'MSG-TOKEN-ERROR'
TO LINK-TEKST
WHEN 2332
MOVE 'MISSING-WIH'
TO LINK-TEKST
WHEN 2333
MOVE 'WIH-ERROR'
TO LINK-TEKST
WHEN 2334
MOVE 'RFH-ERROR'
TO LINK-TEKST
WHEN 2335
MOVE 'RFH-STRING-ERROR'
TO LINK-TEKST
WHEN 2336
MOVE 'RFH-COMMAND-ERROR'
TO LINK-TEKST
WHEN 2337
MOVE 'RFH-PARM-ERROR'
TO LINK-TEKST
WHEN 2338
MOVE 'RFH-DUPLICATE-PARM'
TO LINK-TEKST
WHEN 2339
MOVE 'RFH-PARM-MISSING'
TO LINK-TEKST
WHEN 2340
MOVE 'CHAR-CONVERSION-ERROR'
TO LINK-TEKST
WHEN 2341
MOVE 'UCS2-CONVERSION-ERROR'
TO LINK-TEKST
WHEN 2342
MOVE 'DB2-NOT-AVAILABLE'
TO LINK-TEKST
WHEN 2343
MOVE 'OBJECT-NOT-UNIQUE'
TO LINK-TEKST
WHEN 2344
MOVE 'CONN-TAG-NOT-RELEASED'
TO LINK-TEKST
WHEN 2345
MOVE 'CF-NOT-AVAILABLE'
TO LINK-TEKST
WHEN 2346
MOVE 'CF-STRUC-IN-USE'
TO LINK-TEKST
WHEN 2347
MOVE 'CF-STRUC-LIST-HDR-IN-USE'
TO LINK-TEKST
WHEN 2348
MOVE 'CF-STRUC-AUTH-FAILED'
TO LINK-TEKST
WHEN 2349
MOVE 'CF-STRUC-ERROR'
TO LINK-TEKST
WHEN 2350
MOVE 'CONN-TAG-NOT-USABLE'
TO LINK-TEKST
WHEN 2351
MOVE 'GLOBAL-UOW-CONFLICT'
TO LINK-TEKST
WHEN 2352
MOVE 'LOCAL-UOW-CONFLICT'
TO LINK-TEKST
WHEN 2353
MOVE 'HANDLE-IN-USE-FOR-UOW'
TO LINK-TEKST
WHEN 2354
MOVE 'UOW-ENLISTMENT-ERROR'
TO LINK-TEKST
WHEN 2355
MOVE 'UOW-MIX-NOT-SUPPORTED'
TO LINK-TEKST
WHEN 2356
MOVE 'WXP-ERROR'
TO LINK-TEKST
WHEN 2357
MOVE 'CURRENT-RECORD-ERROR'
TO LINK-TEKST
WHEN 2358
MOVE 'NEXT-OFFSET-ERROR'
TO LINK-TEKST
WHEN 2359
MOVE 'NO-RECORD-AVAILABLE'
TO LINK-TEKST
WHEN 2360
MOVE 'OBJECT-LEVEL-INCOMPATIBLE'
TO LINK-TEKST
WHEN 2361
MOVE 'NEXT-RECORD-ERROR'
TO LINK-TEKST
WHEN 2362
MOVE 'BACKOUT-THRESHOLD-REACHED'
TO LINK-TEKST
WHEN 2363
MOVE 'MSG-NOT-MATCHED'
TO LINK-TEKST
WHEN 2364
MOVE 'JMS-FORMAT-ERROR'
TO LINK-TEKST
WHEN 2365
MOVE 'SEGMENTS-NOT-SUPPORTED'
TO LINK-TEKST
WHEN 2366
MOVE 'WRONG-CF-LEVEL'
TO LINK-TEKST
WHEN 2367
MOVE 'CONFIG-CREATE-OBJECT'
TO LINK-TEKST
WHEN 2368
MOVE 'CONFIG-CHANGE-OBJECT'
TO LINK-TEKST
WHEN 2369
MOVE 'CONFIG-DELETE-OBJECT'
TO LINK-TEKST
WHEN 2370
MOVE 'CONFIG-REFRESH-OBJECT'
TO LINK-TEKST
WHEN 2371
MOVE 'CHANNEL-SSL-ERROR'
TO LINK-TEKST
WHEN 2373
MOVE 'CF-STRUC-FAILED'
TO LINK-TEKST
WHEN 2374
MOVE 'API-EXIT-ERROR'
TO LINK-TEKST
WHEN 2375
MOVE 'API-EXIT-INIT-ERROR'
TO LINK-TEKST
WHEN 2376
MOVE 'API-EXIT-TERM-ERROR'
TO LINK-TEKST
WHEN 2377
MOVE 'EXIT-REASON-ERROR'
TO LINK-TEKST
WHEN 2378
MOVE 'RESERVED-VALUE-ERROR'
TO LINK-TEKST
WHEN 2379
MOVE 'NO-DATA-AVAILABLE'
TO LINK-TEKST
WHEN 2380
MOVE 'SCO-ERROR'
TO LINK-TEKST
WHEN 2381
MOVE 'KEY-REPOSITORY-ERROR'
TO LINK-TEKST
WHEN 2382
MOVE 'CRYPTO-HARDWARE-ERROR'
TO LINK-TEKST
WHEN 2383
MOVE 'AUTH-INFO-REC-COUNT-ERROR'
TO LINK-TEKST
WHEN 2384
MOVE 'AUTH-INFO-REC-ERROR'
TO LINK-TEKST
WHEN 2385
MOVE 'AIR-ERROR'
TO LINK-TEKST
WHEN 2386
MOVE 'AUTH-INFO-TYPE-ERROR'
TO LINK-TEKST
WHEN 2387
MOVE 'AUTH-INFO-CONN-NAME-ERROR'
TO LINK-TEKST
WHEN 2388
MOVE 'LDAP-USER-NAME-ERROR'
TO LINK-TEKST
WHEN 2389
MOVE 'LDAP-USER-NAME-LENGTH-ERR'
TO LINK-TEKST
WHEN 2390
MOVE 'LDAP-PASSWORD-ERROR'
TO LINK-TEKST
WHEN 2391
MOVE 'SSL-ALREADY-INITIALIZED'
TO LINK-TEKST
WHEN 2392
MOVE 'SSL-CONFIG-ERROR'
TO LINK-TEKST
WHEN 2393
MOVE 'SSL-INITIALIZATION-ERROR'
TO LINK-TEKST
WHEN 2394
MOVE 'Q-INDEX-TYPE-ERROR'
TO LINK-TEKST
WHEN 2395
MOVE 'CFBS-ERROR'
TO LINK-TEKST
WHEN 2396
MOVE 'SSL-NOT-ALLOWED'
TO LINK-TEKST
WHEN 2397
MOVE 'JSSE-ERROR'
TO LINK-TEKST
WHEN 2398
MOVE 'SSL-PEER-NAME-MISMATCH'
TO LINK-TEKST
WHEN 2399
MOVE 'SSL-PEER-NAME-ERROR'
TO LINK-TEKST
WHEN 2400
MOVE 'UNSUPPORTED-CIPHER-SUITE'
TO LINK-TEKST
WHEN 2401
MOVE 'SSL-CERTIFICATE-REVOKED'
TO LINK-TEKST
WHEN 2402
MOVE 'SSL-CERT-STORE-ERROR'
TO LINK-TEKST
WHEN 2406
MOVE 'CLIENT-EXIT-LOAD-ERROR'
TO LINK-TEKST
WHEN 2407
MOVE 'CLIENT-EXIT-ERROR'
TO LINK-TEKST
WHEN 2409
MOVE 'SSL-KEY-RESET-ERROR'
TO LINK-TEKST
WHEN 2410
MOVE 'UNKNOWN-COMPONENT-NAME'
TO LINK-TEKST
WHEN 2411
MOVE 'LOGGER-STATUS'
TO LINK-TEKST
WHEN 2412
MOVE 'COMMAND-MQSC'
TO LINK-TEKST
WHEN 2413
MOVE 'COMMAND-PCF'
TO LINK-TEKST
WHEN 2414
MOVE 'CFIF-ERROR'
TO LINK-TEKST
WHEN 2415
MOVE 'CFSF-ERROR'
TO LINK-TEKST
WHEN 2416
MOVE 'CFGR-ERROR'
TO LINK-TEKST
WHEN 2417
MOVE 'MSG-NOT-ALLOWED-IN-GROUP'
TO LINK-TEKST
WHEN 2418
MOVE 'FILTER-OPERATOR-ERROR'
TO LINK-TEKST
WHEN 2419
MOVE 'NESTED-SELECTOR-ERROR'
TO LINK-TEKST
WHEN 2420
MOVE 'EPH-ERROR'
TO LINK-TEKST
WHEN 2421
MOVE 'RFH-FORMAT-ERROR'
TO LINK-TEKST
WHEN 2422
MOVE 'CFBF-ERROR'
TO LINK-TEKST
WHEN 2423
MOVE 'CLIENT-CHANNEL-CONFLICT'
TO LINK-TEKST
WHEN 6100
MOVE 'REOPEN-EXCL-INPUT-ERROR'
TO LINK-TEKST
WHEN 6101
MOVE 'REOPEN-INQUIRE-ERROR'
TO LINK-TEKST
WHEN 6102
MOVE 'REOPEN-SAVED-CONTEXT-ERR'
TO LINK-TEKST
WHEN 6103
MOVE 'REOPEN-TEMPORARY-Q-ERROR'
TO LINK-TEKST
WHEN 6104
MOVE 'ATTRIBUTE-LOCKED'
TO LINK-TEKST
WHEN 6105
MOVE 'CURSOR-NOT-VALID'
TO LINK-TEKST
WHEN 6106
MOVE 'ENCODING-ERROR'
TO LINK-TEKST
WHEN 6107
MOVE 'STRUC-ID-ERROR'
TO LINK-TEKST
WHEN 6108
MOVE 'NULL-POINTER'
TO LINK-TEKST
WHEN 6109
MOVE 'NO-CONNECTION-REFERENCE'
TO LINK-TEKST
WHEN 6110
MOVE 'NO-BUFFER'
TO LINK-TEKST
WHEN 6111
MOVE 'BINARY-DATA-LENGTH-ERROR'
TO LINK-TEKST
WHEN 6112
MOVE 'BUFFER-NOT-AUTOMATIC'
TO LINK-TEKST
WHEN 6113
MOVE 'INSUFFICIENT-BUFFER'
TO LINK-TEKST
WHEN 6114
MOVE 'INSUFFICIENT-DATA'
TO LINK-TEKST
WHEN 6115
MOVE 'DATA-TRUNCATED'
TO LINK-TEKST
WHEN 6116
MOVE 'ZERO-LENGTH'
TO LINK-TEKST
WHEN 6117
MOVE 'NEGATIVE-LENGTH'
TO LINK-TEKST
WHEN 6118
MOVE 'NEGATIVE-OFFSET'
TO LINK-TEKST
WHEN 6119
MOVE 'INCONSISTENT-FORMAT'
TO LINK-TEKST
WHEN 6120
MOVE 'INCONSISTENT-OBJECT-STATE'
TO LINK-TEKST
WHEN 6121
MOVE 'CONTEXT-OBJECT-NOT-VALID'
TO LINK-TEKST
WHEN 6122
MOVE 'CONTEXT-OPEN-ERROR'
TO LINK-TEKST
WHEN 6123
MOVE 'STRUC-LENGTH-ERROR'
TO LINK-TEKST
WHEN 6124
MOVE 'NOT-CONNECTED'
TO LINK-TEKST
WHEN 6125
MOVE 'NOT-OPEN'
TO LINK-TEKST
WHEN 6126
MOVE 'DISTRIBUTION-LIST-EMPTY'
TO LINK-TEKST
WHEN 6127
MOVE 'INCONSISTENT-OPEN-OPTIONS'
TO LINK-TEKST
WHEN 6128
MOVE 'WRONG-VERSION'
TO LINK-TEKST
WHEN 6129
MOVE 'REFERENCE-ERROR'
TO LINK-TEKST
END-EVALUATE
END-IF
WHEN LINK-DOMAIN(1:3) = 'XML'
EVALUATE LINK-REASON
WHEN 798721
MOVE
'Dublicate namespace declaration found'
TO LINK-TEKST
WHEN 798722
MOVE
'Namespace prefix on attribute not declared'
TO LINK-TEKST
WHEN 798723
MOVE
'Namespace prefix on element tag not declared'
TO LINK-TEKST
WHEN 798724
MOVE
'Encoding at beginning of document is unsupported'
TO LINK-TEKST
WHEN 798725
MOVE
'Incorrectly encoded character found in the input stream'
TO LINK-TEKST
WHEN 798727
MOVE
'Comment without starting dash found'
TO LINK-TEKST
WHEN 798729
MOVE
'Comment right angle is missing'
TO LINK-TEKST
WHEN 798736
MOVE
'CDATA keyword expected but not found'
TO LINK-TEKST
WHEN 798737
MOVE
'Left square bracket expected in CDATA markup'
TO LINK-TEKST
WHEN 798737
MOVE
'A character was found that is not allowed within a CDATA sec
- 'tion'
TO LINK-TEKST
WHEN 798743
MOVE
'Invalid character found within a Processing Instruction'
TO LINK-TEKST
WHEN 798744
MOVE
'Invalid character in attribute name'
TO LINK-TEKST
WHEN 798745
MOVE
'Invalid character in an attribute local name'
TO LINK-TEKST
WHEN 798752
MOVE
'Attribute name not followed by the character "="'
TO LINK-TEKST
WHEN 798753
MOVE
'Attribute name followed by "=" but no quote after "="'
TO LINK-TEKST
WHEN 798761
MOVE
'An incorrect character is found within markup'
TO LINK-TEKST
WHEN 798769
MOVE
'An incorrect character is found in an element tag name'
TO LINK-TEKST
WHEN 798770
MOVE
'An incorrect character is found in an element tag name'
TO LINK-TEKST
WHEN 798770
MOVE
'An incorrect character is found in an element start tag'
TO LINK-TEKST
WHEN 798772
MOVE
'"/" not followed by ">" in an end for an element tag'
TO LINK-TEKST
WHEN 798773
MOVE
'Element end tag do not match the name of the start tag'
TO LINK-TEKST
WHEN 798776
MOVE
'Incorrect character i namespace URI'
TO LINK-TEKST
WHEN 798784
MOVE
'Incorrect character in prefix name in namespace declaration'
TO LINK-TEKST
WHEN 798785
MOVE
'"=" not followed by quote in namespace declaration'
TO LINK-TEKST
WHEN 798790
MOVE
'XML version number is invalid, only "1.0" and "1.1" are vali
- 'd'
TO LINK-TEKST
WHEN 798791
MOVE
'The word "version" in xml declaration is misspelled'
TO LINK-TEKST
WHEN 798792
MOVE
'No "=" after "version" in xml declaration'
TO LINK-TEKST
WHEN 798793
MOVE
'No quote after "version=" in xml declaration'
TO LINK-TEKST
WHEN 798800
MOVE
'"version=" in xml declaration contains invalid character'
TO LINK-TEKST
WHEN 798801
MOVE
'XML declaration contains invalid character'
TO LINK-TEKST
WHEN 798802
MOVE
'The word "encoding" in xml declaration is misspelled'
TO LINK-TEKST
WHEN 798803
MOVE
'No "=" after "encoding" in xml declaration'
TO LINK-TEKST
WHEN 798804
MOVE
'No quote after "encoding=" in xml declaration'
TO LINK-TEKST
WHEN 798805
MOVE
'"encoding" in xml declaration contains invalid character'
TO LINK-TEKST
WHEN 798806
MOVE
'The word "standalone" in xml declaration is misspelled'
TO LINK-TEKST
WHEN 798807
MOVE
'"standalone" in xml declaration must be "yes" or "no"'
TO LINK-TEKST
WHEN 798808
MOVE
'No "=" after "standalone" in xml declaration'
TO LINK-TEKST
WHEN 798809
MOVE
'No quote after "standalone=" in xml declaration'
TO LINK-TEKST
WHEN 798816
MOVE
'End of XML-declaration contains invalid character, not "?>"'
TO LINK-TEKST
WHEN 798818
MOVE
'Invalid character. Either "<" or whitespace was expected'
TO LINK-TEKST
WHEN 798819
MOVE
'First character in document is not "<" or whitespace'
TO LINK-TEKST
WHEN 798820
MOVE
'No character before XML-declaration is allowed (except "BOM"
- ')'
TO LINK-TEKST
WHEN 100000 THRU 165535
MOVE
'Codepage compile option and encoding declaration specifies
- 'differenct EBCDIC code pages '
TO LINK-TEKST
WHEN ANY
MOVE LINK-REASON TO XML-DECODE
MOVE RTN TO RTN-DISPL
STRING "RC= " RTN-DISPL ", reason=X'"
HV(FUNCTION MOD(RSN / 4096 16) + 1:1)
HV(FUNCTION MOD(RSN / 256 16) + 1:1)
HV(FUNCTION MOD(RSN / 16 16) + 1:1)
HV(FUNCTION MOD(RSN 16) + 1:1) "' "
"XML-parse error. See z/OS XML System Services User's Guid
- "e and Reference ."
DELIMITED BY SIZE INTO LINK-TEKST
END-EVALUATE
WHEN ANY
MOVE
'FEJLUD: DOMAIN i kaldet ikke kendt'
TO LINK-TEKST
END-EVALUATE
GOBACK.
END PROGRAM FEJLUDTX.
END PROGRAM RXSDO.