AGO .START
C:\USERS\LIN\DOCUMENTS\Z390CODE\QSTRING1
FIND PARM STRING IN A TAPE FILE. JCL LOOKS LIKE
//SCAN EXEC PGM=QSTRING1,PARM=ABC
//STEPLIB DD DISP=SHR,DSN= ????
//SYSPRINT DD SYSOUT=*
//IN DD DISP=SHR,DSN= ???
//OUT DD ....
A COUPLE OF ERROR MESSAGES ARE PUT INTO SYSMSGS FOLLOWED BY ABEND.
YOU CAN ALSO HAVE A HEX PARM, LIKE: THESE ARE FOR CHECKING THE 1ST
X'C1C2C3' OR X"C4C5C6" OR X$C7C8C9$ AND LAST LOCATION TESTED.
OR C"ABC" OR C'DEF' OR C$GHI$ 60 WXYZ
61 WXYZ
NEED TO UNCOMMENT DCBD, ADD OPEN EXIT ON //OUT 62 WXYZ
AND DELETE CODE BEFORE OPEN (OUT,OUTPUT) 63 WXYZ
MIGHT WANT DEVD=DA IN DCB FIELDS 64 WXYZ
65 WXYZ
MANY OF US HAVE WRITTEN "FIND A STRING" PROGRAMS. 66 WXYZ
I WROTE THIS ONE BECAUSE I FOUND A BETTER METHOD OF 67 WXYZ
OF DETERMINING THE LEAST FREQUENTLY USED CHAR IN A 68 WXYZ
STRING. IT'S CLEANER, QUICKER, AND A BIT SHORTER. 69 WXYZ
70 WXYZ
WXYZ 1
WXYZ 2
WXYZ 3
WXYZ 4
.START ANOP
* -----------------------------------------------------------
MACRO
&LABEL ERR &IF,&MSG
LCLA &N
LCLC &Z
&Z SETC 'SYS&SYSNDX.Z'
&N SETA (K'&MSG)
&N SETA &N-3
&LABEL REVB &IF,&Z
BAL R14,ERR
DC AL1(&N),C&MSG
&Z DS 0H
MEND
* -----------------------------------------------------------
MACRO
&LABEL REVB &COND,&TO
LCLC &C,&B
LCLA &LEN
AIF ('&COND' NE 'B').ADDREM
&LABEL NOP &TO
MEXIT
.ADDREM ANOP
&LEN SETA K'&COND
AIF ('&COND'(2,1) NE 'N').ADD
&B SETC '&COND'(3,&LEN-2)
AGO .DOIT
.ADD ANOP
&B SETC '&COND'(2,&LEN-1)
&B SETC 'N&B'
.DOIT ANOP
&LABEL B&B &TO
MEND
* ---------------------------------
QSTRING1 START 0 FAST SCAN OF A FILE
USING *,13 LOOKING FOR THE STRING SPECIFIED IN
YREGS , THE PARM FIELD.
B BEGIN-*(15) BRANCH AROUND SAVE AREA
DC 17F'0'
IDMSG DC C'QSTRING1 ASM V01.01 &SYSDATE &SYSTIME LINLYONS@YAHOO.COM'
IDMSG2 DC C'COPY RECORDS CONTAINING STRING SPECIFIED IN PARM FIELD'
IDNC DC 8X'BF',X'FF',5X'BF',X'FF',3X'BF'
* === NOTE, THE FOLLOWING CODE IS OVERLAID WITH HEX PARM DATA =========
BEGIN STM 14,12,12(13) GENERAL
ST 15,8(13) START
ST 13,4(15) HOUSE KEEPING
LR 13,15 STUFF
L 8,0(1) LOAD ADDR OF PARM
ST R8,APARM
LH R5,0(R8) LOAD LENGTH OF PARM
LR R6,R5 SAVE BOTH LENGTH
BCTR R5,0 CALC LENGTH-1
*
NC IDMSG+L'IDMSG-18(18),IDNC
LA R2,SYSPRINT
BAL R9,OPENSYSP
LA R2,IN
BAL R9,OPENIN
LA R2,OUT
BAL R9,OPENOUT
LTR R6,R6
ERR BZ,'PARM MISSING, MUST CONTAIN SEARCH STRING'
CLI 1(R8),5
BL NOTQUOTE
* ====================== CODE TO DEAL WITH X"CAC2C3" IN PARM ==========
LA R1,1(R6,R8)
CLC 3(1,R8),0(R1) C"ABC" CHECK MATCHING QUOTES
BNE NOTQUOTE NO, IT'S A PLANE STRING.
CLI 3(R8),C'"' CHECK FOR VALID QUOTE,
BE GOTQUOT " ' $
CLI 3(R8),C'''' IF NOT ONE OF THOSE, ASSUME STRING
BE GOTQUOT
CLI 3(R8),C'$'
BNE NOTQUOTE
* GOTQUOT MVC HEXQ,2(R8)
GOTQUOT CLI 2(R8),C'C'
BE CHARPARM
CLI 2(R8),C'X'
ERR BNE,'DATA TYPE INCORRECT, MUST BE C/X'
*
TM 1(R8),1
ERR BNO,'ODD # HEX DIGITS'
LH R2,0(R8)
SH R2,=H'4'
TRTHEX TRT 4(0,R8),TESTHEX-193
EX R2,TRTHEX
ERR BO,'BAD HEX CHAR'
*
LR R0,R5
SRL R0,1
BCTR 0,0
STH R0,BEGIN+2
*
LA R14,4(R8)
LA R15,BEGIN+4
PACKPARM MVC BEGIN(2),0(R14)
TR BEGIN(2),MAKEHEX-193
PACK 0(2,R15),BEGIN(3)
LA R14,2(R14)
LA R15,1(R15)
BCT R0,PACKPARM
*
LA R8,BEGIN+2
** MVC MSG+17(20),=CL20'COPIED'
B NOTQUOTE
* HEXQ DC C'X"',C'X''',C'X$'
* IDNC DC 8X'BF',X'FF',9X'BF'
* BADPARM WTO 'PARM CAN ONLY CONTAIN HEX AND CHAR DATA',ROUTCDE=11
* ABEND 3
* BADHEX WTO 'PARM CONTAINS INVALID HEX CHARACTERS',ROUTCDE=11
* ABEND 2 QUIT IF NO PARM
* NOPARM WTO 'PARM MISSING, MUST CONTAIN SEARCH STRING',ROUTCDE=11
* ABEND 1 QUIT IF NO PARM
* ================ END OF HEX PARM PROCESSING ========================
PREPOST DC 2H'0',2C' ' #BYTES BEFORE SEARCH CHAR AND #BYTES AFTER
* MVCPARM MVC MSG+30(0),2(R8)
*
MVC BEGIN+4(0),4(R8)
CHARPARM SH R5,=H'3'
SH R6,=H'3'
EX R5,CHARPARM-6
STH R6,BEGIN+2
LA R8,BEGIN+2
NOTQUOTE LR 15,8
LH R5,0(R8) LOAD LENGTH OF PARM
LR R6,R5 SAVE BOTH LENGTH
BCTR R5,0 CALC LENGTH-1
*
LA 14,PREPOST
BAL R9,QFREQ
SR 1,1
IC 1,PREPOST+4 FOR 1ST CHAR OF STRING
LA R1,TRTTBL(R1)
MVI 0(R1),C'F'
*
MVC LINE(07),=C'PARM = '
L R7,APARM
LH R5,0(R7)
BCTR R5,0
MVC LINE+7(0),2(R7)
EX R5,*-6
LA R15,LINE+11(R5)
MVC 0(08,R15),=C'SCAN FOR'
LA R15,10(R15)
LA R14,PREPOST
BAL R9,CONVH
MVC 0(1,R15),PREPOST+4
CLI 2(R7),C'X'
BNE NOTX
UNPK 0(3,R15),PREPOST+4(2)
TR 0(2,R15),HEX-240
MVI 2(R15),C' '
LA R15,1(R15)
NOTX LA R15,2(R15)
LA R14,PREPOST+2
BAL R9,CONVH
*
PUT SYSPRINT,LINE-1
MVC LINE,LINE-1
LH R5,0(R8)
BCTR R5,0
B GET AND GO READ
*
CONVH LH R0,0(R14)
CVD R0,DW
OI DW+7,X'0F'
UNPK 0(3,R15),DW+6(2)
LA R15,4(R15)
BR R9
* =============================== THIS SECTION IS THE PROGRAM ========
DC F'0'
PUT L R0,PUT-4 WRITE IF FOUND
PUT OUT,(0) WRITE IF FOUND
AP COUNTOUT,P1 COUNT IT
GET GET IN READ
AP COUNTIN,P1
ST R1,PUT-4 SAVE REC ADDR
LH R4,DCBLRECL-IHADCB+IN
TM DCBRECFM-IHADCB+IN,X'80' Q. RECFM=FB
BO *+8 YES.
LH R4,0(R1) NO, LOAD LENGTH FROM REC
*** LA R4,65 ==== FOR TESTING ==========
LA R4,1(R4,R1) POINT TO END OF REC
SH R4,PREPOST+2 BACK UP TO NOT TEST END
L R1,PUT-4
AH R1,PREPOST POINT PAST FRONT
* ===================== THIS IS THE BUSINESS SECTION ===============
LOOP LR R2,R4 POINT TO END OF REC
SR R2,R1 CALC LENGTH LEFT TO TEST
BM GET SHORT, GO READ NEXT
CH R2,=H'256'
BL SHORT
TRT 0(256,R1),TRTTBL
BNZ FOUND
LA R1,256(R1)
B LOOP
TRT TRT 0(0,R1),TRTTBL
CLC CLC 2(0,R8),0(R3) COMPARE STRING TO REC LOCATIONS
SHORT EX R2,TRT SCAN FOR FIRST CHAR OF PARM
BZ GET NOT FOUND, GO READ
FOUND LR R3,R1
SH R3,PREPOST
EX R5,CLC FOUND, COMPARE
BE PUT MATCH, GO WRITE
LA R1,1(R1) NOT MATCH, BUMP LOCATION
B LOOP AND LOOP
* ================================= END OF THE PROGRAM ===============
ED15 DC 0XL20,X'40202020',3X'6B202020',X'6B212020',C'$'
REPORT MVC LINE,LINE-1
MVC LINE(L'ED15),ED15
MVC LINE+1+L'ED15(16),8(R2)
LA R1,LINE+L'ED15-3
EDMK LINE(L'ED15),0(R2)
MVC LINE(77),0(R1)
PUT SYSPRINT,LINE-1
BR R9
*
Z CLOSE (IN,,OUT) DONE, CLOSE FILES
LA R2,COUNTIN
BAL R9,REPORT
LA R2,COUNTOUT
BAL R9,REPORT
*
L 13,4(13) ---------NORMAL HOUSEKEEPING CLEAN UP
LM 14,12,12(13)
SR 15,15
BR 14 EXIT
* -------------------THIS IS BOTH A MSG AND AN ERROR MSG RTN---------
DC F'0'
ERR LA 14,0(14)
ST 14,ERR-4
LR 15,14
SR 15,13
ST 15,8(13)
MVC LINE,LINE-1
MVC LINE(3),=C'ERR'
UNPK LINE+4(5),10(3,13)
TR LINE+4(4),HEX-240
MVI LINE+8,C' '
CLI 1(R14),C' '
BNE *+10
MVC LINE(3),=C'MSG'
SR 1,1
IC 1,0(14)
MVC LINE+09(0),1(14)
EX 1,*-6
PUT SYSPRINT,LINE-1
L R14,ERR-4
SH R14,=H'8'
LA R15,X'F0'
CLI 9(R14),C' '
MVC LINE,LINE-1
BNE *+8
EX R15,0(14)
ABEND 1
* -----------------END OF ERR/MSG ROUTINE----OPEN ROUTINE----
USING IHADCB,2
OPENOUT MVC OPENMSG(8),DCBDDNAM
CLC =H'0',DCBLRECL
BNE OPENOO
MVC DCBRECFM,DCBRECFM-IHADCB+IN
MVC DCBLRECL,DCBLRECL-IHADCB+IN
B OPENOO
PUSH PRINT
PRINT NOGEN
OPENSYSP MVC OPENMSG(8),DCBDDNAM
OPENOO OPEN ((2),OUTPUT)
MVC OPENMSG+20(3),=C'OUT'
CLC OPENMSG(8),=C'SYSPRINT'
BNE LISTDCBM
MVC LINE(L'IDMSG),IDMSG
PUT SYSPRINT,LINE-1
MVC LINE(L'IDMSG2),IDMSG2
PUT SYSPRINT,LINE-1
MVC LINE,LINE-1
B LISTDCBM
OPENMSG DC C' OPENED FOR OUTPUT, RECFM= LRECL='
OPENIN MVC OPENMSG(8),DCBDDNAM
OPEN ((2),INPUT)
POP PRINT
MVC OPENMSG+20(3),=C' IN'
LISTDCBM UNPK OPENMSG+34(3),DCBRECFM(2)
TR OPENMSG+34(2),HEX-240
MVI OPENMSG+36,C' '
LH R0,DCBLRECL
CVD R0,16(13)
OI 23(13),X'0F'
MVC LINE(L'OPENMSG),OPENMSG
UNPK LINE+L'OPENMSG(5),21(3,13)
DROP 2
*
PUTLINE PUT SYSPRINT,LINE-1
MVC LINE,LINE-1
BR R9
*
LTORG
DW DC D'0'
APARM DC F'0'
COUNTIN DC PL8'0',CL16'RECORDS READ'
COUNTOUT DC PL8'0',CL16'RECORDS WRITTEN'
LINE DC CL133' '
HEX DC C'0123456789ABCDEF'
P1 DC X'1C'
TRTTBL DC XL256'00'
*
LTORG
EXLST DC A(EXLST+4+X'87000000')
USING *,15
CLI DCBRECFM-IHADCB+IN,0
BNER 14
MVC DCBRECFM-IHADCB+OUT,DCBRECFM-IHADCB+IN
MVC DCBLRECL-IHADCB+OUT,DCBLRECL-IHADCB+IN
BR 14
DROP 15
PUSH PRINT
PRINT NOGEN
* ---------------------------------
IN DCB DDNAME=IN,DSORG=PS,MACRF=GL,RECFM=FT,LRECL=266, X
EODAD=Z
OUT DCB DDNAME=OUT,DSORG=PS,MACRF=PM ,EXLST=EXLST
SYSPRINT DCB DDNAME=SYSPRINT,DSORG=PS,MACRF=PM,RECFM=FT,LRECL=133
* -------------------------------------------------
POP PRINT
TR 0(0,R3),QFREQTBL
MVC 0(0,R3),2(R15)
QFREQ STM R2,6,58(R13) 15 = STRING
LA R3,8(13) 14 = PRE-LEN, POST-LEN, CHAR
LH R1,0(R15)
BCTR R1,0
EX R1,QFREQ-6 MOVE STRING TO WORK AREA (UP TO 50)
EX R1,QFREQ-12 TRAN TO FREQ VALUES
LR R0,R1 LOAD CHAR COUNT-1
LR R4,R3 POINT TO FIRST FREQ VALUE
LR R5,R3 R5 = PLACE TO SAVE LOWEST
LA R6,1(R3,R1) R6 = LAST TO CALC POST LEN (CHARS AFTER)
QFREQL CLC 0(1,R4),0(R5) Q. IS THIS THE LOWEST SO FAR?
BNL *+6 NO
LR R5,R4 YES, SAVE IT
LA R4,1(R4) BUMP TO NEXT
BCT R0,QFREQL AND LOOP
LR R0,R6 CALC LAST
SR R0,R5 - LOW LOC
BCTR R0,0
STH R0,2(R14) = POST LENG, SAVE IT
LR R1,R5 CALC LOW
SR R1,R3 - FIRST = PRE LENG
STH R1,0(R14) = PRE LENG, SAVE THAT
LA R2,2(R1,R15) POINT TO LOW CHAR
MVC 4(1,R14),0(R2) AND SAVE THAT
LM R2,R6,58(R13) RELOAD REGS
BR R9 AND RETURN
*
* HTTPS://EN.WIKIPEDIA.ORG/WIKI/LETTER_FREQUENCY
QFREQTBL DC X'898887',253X'86' ASCII FIRST (WIKIOPEDIA)
ORG QFREQTBL+X'30'
DC X'59585756555453525150' NUMBERS
ORG QFREQTBL+X'40'
DC X'27161D20291A18222513141F1B242617112123281E151C121910' UPPER
ORG QFREQTBL+X'60'
DC X'47363D40493A38424533343F3B444637314143463E353C323930' LOWER
*
ORG QFREQTBL+X'C1' EBCDIC UPPER
DC X'27161D20291A182225'
ORG QFREQTBL+X'D1'
DC X'13141F1B2426171121'
ORG QFREQTBL+X'E2'
DC X'23281E151C121910'
*
ORG QFREQTBL+X'81' LOWER
DC X'47363D40493A384245'
ORG QFREQTBL+X'91'
DC X'33343F3B4446373141'
ORG QFREQTBL+X'A2'
DC X'43463E353C323930' LOWER
*
ORG QFREQTBL+X'F0'
DC X'59585756555453525150' NUMBERS
*
TESTHEX DC 6X'00',41C' ',10X'00',6C' '
MAKEHEX DC X'0A0B0C0D0E0F',41C' ',X'00010203040506070809'
* -------------------------------------------------
@@PAD#0 EQU *-QSTRING1+4095
@@PAD#1 EQU @@PAD#0/(4097)
@@PAD#2 EQU (@@PAD#1*4096)
ORG QSTRING1+@@PAD#2
*
* DCBD DEVD=DA
END QSTRING1