Macro .*- .* Test string against a pattern/mask. STRMACS .* .* Syntax .* STRPATRN DATA=data-addr,MASK=mask-addr,WC=ao|*% .* .* 'addr' is either a label, or (label,len) or 'literal'. 'label' .* and 'len' may be a register like (rn) or f/h/b/c.label to load .* from a fullword, halfword, byte or char field. See .XLA below. .* The mask may contain wildcards % for a single char and * for .* multiple or no chars. .* 'ao' mask chars for all or none, or any one char. default is *%. .* STR= can be used instead of DATA=. This will probably be removed .* in a later version, so please use DATA=. .* .* Returns result in r15: .* 0 Data matches mask .* >1 Data does not match mask, code indicates where in STRPATRN .* the check failed. Additional info is returned as follows: .* r0 -> data addr when check failed .* r1 -> mask addr when check failed .* .* Operation .* First time the macro is invoked an internal CSECT is generated, .* further macro invocations call the same CSECT. .* The save area pointed to by r13 is used as work area both for .* the call parameters and for saving registers. Registers 4-12 are .* restore when the program returns, registers 2 and 3 are not used .* so need not be preserved. Registers 0, 1, 14 and 15 are changed .* by the macro. .* .* Samples .* STRPATRN data=text1,mask=mask1 .* STRPATRN data='ABCDE',mask='A%C*' .* STRPATRN data=((r2),(r3)),mask=(f.maskaddr,b.masklen) .* STRPATRN data=text1,mask='Doc*Brit*' .* . . .* text1 dc c'Doctor Who is a British sci-fi TV series' .* mask1 dc c'*Who*Brit*' .* maskaddr ds a contains address of mask .* masklen ds al1 max len 128 as field is signed .* .* Note that IBM supplies a similar function in macro ASAXWC in .* SYS1.MODGEN. STRPATRN, however, is simpler to use and test has .* shown it to be up to 4 times as fast as ASAXWC. .* .* History .* 2019-12-01 Total rewrite, so is now new base .* 2020-07-21 Fix false negative with equal mask- and string length .* 2022-05-12 Remove unneccesary LTORG. .* 2022-10-26 Fix problem with 1 char after last asterix i.a. ABC*F .* .* Author .* Willy Jensen .* mail: willy@harders-jensen.com .* web : http://harders-jensen.com/wjtech .*- &ml STRPATRN &str=,&data=,&mask=,&wc='*%' lclc &l,&s,&c lcla &qn &l setc 'sp&sysndx' gblb &$STRPATRN .* xla sub gblc &xlalen &s setc Upper('&syslist(1)') aif ('&s' eq 'XLA').xla .* call mnote *,'Version 2022-10-26' &ml la r1,8(,r13) STRPATRN XLA,r14,&data(1),&str(1) STRPATRN XLA,r15,&data(2),&str(2),&xlalen,1 stm r14,r15,0(r1) STRPATRN XLA,r14,&mask(1) STRPATRN XLA,r15,&mask(2),&xlalen,1 stm r14,r15,8(r1) STRPATRN XLA,r14,&wc mvc 16(2,r1),0(r14) mvc 18(2,r1),=x'0000' l r15,=v(ZTRPATRN) basr r14,r15 aif (&$STRPATRN).x &$STRPATRN setb 1 j &l.ltn .* ltorg !not needed! &l.ltn ds 0a * STRPATRN module * r14 return address * r12 basereg * r11 -> string * r10 -> mask * r9 -> string end * r8 -> mask end * r7 wildcards : byte0 is 'all', byte1 = one * r6 -> save mask ptr * r5 -> last '*' * r2-r4 are not used, they are not saved and restored as that space in * the save area is used for the parm block. &s setc '&sysect' ZTRPATRN Amode 31 ZTRPATRN Rmode any ZTRPATRN Csect save (4,12) push using lr r12,r15 using ZTRPATRN,r12 * set up registers using zptrnblk,r1 l r11,zptrnsa -> string l r9,zptrnsl string length ar r9,r11 -> past string ahi r9,-1 -> end of string l r10,zptrnma -> mask l r8,zptrnml mask length ar r8,r10 -> past mask ahi r8,-1 -> end of mask l r7,zptrnwc wild cards and opts * special case, mask='*' (fix 2020-07-21) la r15,1 c r15,zptrnml masklen=1 ? jne &l.f001 no clm r7,8,0(r10) mask = '*' ? je &l.q0 yes &l.f001 equ * *- * Frontend - till '*' or end of mask or end of string *- drop r1 &l.f100 equ * clm r7,8,0(r10) '*' ? je &l.f400 then go handle block * test char &l.f200 equ * clm r7,4,0(r10) '%' ? je &l.f300 yes clc 0(1,r10),0(r11) same char in string and mask? jne &l.fe01 no, abort * char ok, check/bump pointers &l.f300 equ * sr r1,r1 mask must also not be at end cr r10,r8 end of mask? .* jnh &l.f302 nope (fix 2020-07-21) jne &l.f302 nope ahi r1,1 mask &l.f302 cr r11,r9 end of data? .* jnh &l.f304 nope (fix 2020-07-21) jne &l.f304 nope ahi r1,1 mark &l.f304 ltr r1,r1 both before end? jz &l.f310 good clfi r1,2 both are at the end je &l.q0 good cr r10,r8 end of mask? je &l.fe03 mask end before string end * string end before mask end, check if mask+1='*' and end of mask ahi r10,1 -> past '*' cr r10,r8 now end of mask? jne &l.fe04 sadly not clm r7,8,0(r10) '*' ? je &l.q0 ok j &l.fe05 bad * both mask and string within bounds, bump and try next &l.f310 equ * ahi r10,1 bump mask ptr ahi r11,1 bump string ptr j &l.f100 continue frontend processing * mask (r10->) chr is '*' &l.f400 equ * cr r10,r8 end of mask? je &l.q0 yup, all is well * handle multiple consequitive '*' &l.f410 equ * ahi r10,1 -> past '*' cr r10,r8 end of mask? je &l.f430 clm r7,8,0(r10) mask is * ? je &l.f410 yes * not end of mask, not '*' &l.f420 equ * ahi r10,-1 -> * ? j &l.f500 go prep for mid- and backend * end of mask .* r9 -> string end .* r8 -> mask end &l.f430 equ * clm r7,8,0(r10) mask is * ? je &l.q0 yes * small backend of one char clm r7,4,0(r10) mask is % ? je &l.q0 yes .* clc 0(1,r10),0(r11) char match ? clc 0(1,r9),0(r8) last char match ? 2022-10-26 je &l.q0 yes j &l.fe06 * mask chr (r10->) is '*', locate last '*' in mask * if this '*' is also last '*' in mask then just do backend &l.f500 equ * lr r5,r8 -> mask end &l.f510 equ * cr r5,r10 test against located '*' je &l.f520 reached that clm r7,8,0(r5) is mask '*' ? je &l.f530 yes bct r5,&l.f510 else go test next * last '*' = first '*' then no mid section, go do backend &l.f520 equ * j &l.bep * last '*' <> first '*' then there is a mid section &l.f530 equ * j &l.msp * Set return codes &l.fe01 la r15,101 j &l.qx &l.fe02 la r15,102 j &l.qx &l.fe03 la r15,103 j &l.qx &l.fe04 la r15,104 j &l.qx &l.fe05 la r15,105 j &l.qx &l.fe06 la r15,106 j &l.qx *- * mid section processing, find matching block in string. * at entry: r10 -> position in mask, r11 -> position in text * r6 -> save mask ptr * r5 -> last '*' *- &l.msp equ * * handle multiple '*' &l.m010 equ * ahi r10,1 -> past '*' clm r7,8,0(r10) mask is * ? jne &l.m100 init properly cr r10,r5 = last '*' ? je &l.m020 yes cr r10,r8 end of mask? je &l.q0 j &l.bep else go do backend * r10 -> last '*', also mask end? &l.m020 equ * cr r10,r8 mask end too? je &l.q0 then all is good j &l.bep else do backend * (re)start at submask &l.m100 equ * lr r6,r10 work mask ptr -> past '*' &l.m200 equ * cr r6,r5 mask work ptr gt subend? jh &l.m100 then iterate &l.m210 equ * cr r11,r9 string gt end? jh &l.me01 then error * test match &l.m300 equ * clm r7,4,0(r6) mask is % ? je &l.m310 clc 0(1,r6),0(r11) mask matches string? jne &l.m400 nope, try next * char match &l.m310 equ * ahi r6,1 bump maskworkptr cr r6,r5 last submsk done? je &l.m600 yes, do backend clm r7,8,0(r6) mask is * ? (submask end) je &l.m500 nope ahi r11,1 bump strptr j &l.m210 cont with test * char don't match &l.m400 equ * cr r6,r10 past 1st char? jh &l.m410 yes ahi r11,1 bump strptr j &l.m100 restart submask &l.m410 equ * j &l.m100 restart submask * submask end &l.m500 equ * la r10,1(,r6) -> past '*' ahi r11,1 bump strptr j &l.m100 restart submask * work ptr -> last '*' &l.m600 equ * cr r6,r8 also end of mask? je &l.q0 lr r10,r6 j &l.bep * Set return code &l.me01 la r15,201 j &l.qx &l.me02 la r15,202 j &l.qx &l.me03 la r15,203 j &l.qx &l.me04 la r15,204 j &l.qx &l.me05 la r15,205 j &l.qx &l.me06 la r15,206 j &l.qx *- * backend procesing, scan backwards till '*' * r11 -> string pos * r10 -> last '*' * r9 -> last byte of pos * r8 -> last byte of mask *- &l.bep equ * ahi r10,1 lr r4,r8 sr r4,r10 length of backend lr r5,r9 sr r5,r11 length of str remainder cr r5,r4 jl &l.be01 &l.b100 equ * clm r7,4,0(r8) mask is % ? je &l.b200 bad if not clc 0(1,r8),0(r9) mask = text? jne &l.be03 bad if not &l.b200 equ * cr r8,r10 locate last mask? jnh &l.q0 then all ok &l.b300 equ * ahi r9,-1 decr string ptr bct r8,&l.b100 decr mask ptr &l.be01 equ * la r15,301 j &l.be99 &l.be02 equ * la r15,302 j &l.be99 &l.be03 equ * la r15,303 j &l.be99 &l.be99 equ * lr r0,r9 copy string addr for reporting lr r1,r8 copy mask addr for reporting j &l.qx *- * return *- &l.q0 equ * set good rc sr r15,r15 set good rc &l.qx lr r0,r11 updated str addr for reporting lr r1,r10 updated mask addr for reporting return (4,12) .* ltorg !not needed! pop using zptrnblk dsect zptrnsa ds a string address zptrnsl ds a string length zptrnma ds a mask address zptrnml ds a mask length zptrnwc ds a wild cards etc zptrnblkl equ *-zptrnblk .* resume main &s Csect resume main Mexit .*- .* $$LA - subroutine, generate Lx instruction (shortened $LA) .* Syntax: $$LA reg,what1,what2,,whatn .* what: label or (reg) or 'literal' or f/h/b/c.label .* c.label -> reg is cleared and the entire byte loaded .* 1st non-null what is used .*- .xla anop lclc &xlar,&xlap,&xla lcla &xlapn,&xlan &xlalen setc '' &xlar setc '&syslist(2)' &xlapn seta 2 .xlanext anop &xlapn seta &xlapn+1 aif (&xlapn gt n'&syslist).xlax &xlap setc '&syslist(&xlapn)' aif (k'&xlap eq 0).xlanext aif ('&xlap '(1,1) eq '(').xlareg aif ('&xlap '(1,1) eq '''').xlalit aif ('&xlap '(2,1) eq '.').xlafld &xla setc t'&xlap aif ('&xla' eq 'N').xlanum &ml la &xlar,&xlap aif ('&xlap '(1,2) eq 'l''').xlax &xlalen setc 'l''&xlap' mexit .xlanum anop &ml lgfi &xlar,&xlap mexit .xlafld anop &xlan seta k'&xlap-2 &xla setc '&xlap'(1,1) &xlap setc '&xlap'(3,&xlan) &xla setc lower('&xla') aif ('&xla' ne 'c' and '&xla' ne 'B').xlafld1 &ml sr &xlar,&xlar ic &xlar,&xlap mexit .xlafld1 aif ('&xla' ne 'f').xlafld2 &xla setc '' .xlafld2 anop &ml l&xla &xlar,&xlap mexit .xlareg anop &xlan seta k'&xlap-2 &xlap setc '&xlap'(2,&xlan) &ml lr &xlar,&xlap mexit .xlalit anop &ml la &xlar,=c&xlap &xlan seta k'&xlap-2 &xlalen setc '&xlan' .xlax mexit .x Mend