/*REXX*/ /*********************************************************************/ /* An exec to receive PDS members transmitted from TSO TRANSMIT cmd. */ /* Copyright 1990,1991,1992,1994 Danal Estes, all rights reserved. */ /*********************************************************************/ /*********************************************************************/ /* Accept arguments and establish defaults */ /*********************************************************************/ Arg aspl afn aft afm . if aspl='?' then call Help if aspl='*' then aspl='' if afn='*' then afn='' if aft='*' then aft='' if afm='' then afm='A' chbuf='' /*establish an empty buffer for CHARIN*/ chbufp=1 /*pointer at first byte */ memcount=0 /*no members processed yet */ first=1 /*boolean: we nead to call first */ open=0 /*boolean: is a file open now? */ call Setnames signal on syntax /*********************************************************************/ /* Clean up reader, and make sure we get the file we want */ /*********************************************************************/ 'execio 0 cp (string CLOSE 00C HOLD' if aspl<>'' then do 'execio 0 cp (string ORDER RDR 'aspl if rc<>0 then croak(aspl' is not a valid RDR spool id.') end /*********************************************************************/ /* Read logical records. Handle according to type. */ /*********************************************************************/ do forever /*INMR06 will cause exit from doctl*/ rec=ReadRec() flg=Substr(rec,2,1) if '20'x=Bitand(flg,'20'x) then call doctl else call dodata end /*main read loop*/ /*********************************************************************/ /*********************************************************************/ /* Process a control record. */ /*********************************************************************/ Doctl: procedure expose rec key. ctl=Substr(rec,3,6) if ctl='INMR06' then call eof if ctl='INMR02' then rec=delstr(rec,1,12) else rec=delstr(rec,1,8) /*loop and extract all keys from this record */ do while length(rec)>0 tkey=nextkey(rec) name=c2x(substr(tkey,1,2)) count=c2d(substr(tkey,3,2)) s=5 do i=1 to count l=c2d(substr(tkey,s,2)) s=s+2 if 'LIT'=Symbol('Key.'name'.'i) then Key.name.i=substr(tkey,s,l) s=s+l end rec=delstr(rec,1,min(length(rec),length(tkey))) end return /*Doctl*/ /*********************************************************************/ /* Process a data record. */ /*********************************************************************/ Dodata: if first then call first /*reads and understands IEBCOPY header recs*/ if ^open then call open substr(rec,7,5) /*cchhr of first data rec */ s=3 /*bump past IDTF length & flags */ do while s0 then croak('Error writing 'fn ft afm', rc='rc) s=s+ulrecl end if blklen=0 then do /*end of current member*/ 'EXECIO 0 DISKW 'FN FT AFM' (FINIS' open=0 end end return /*Dodata*/ /*********************************************************************/ /* Check that we have all required knowledge to deal with this data */ /*********************************************************************/ First: first=0 if 'IEBCOPY'<>Key.utiln.1 then croak('Not unloaded IEBCOPY format') /*change broken up dsn into one string*/ dsn='' do i=1 to 22 if 'LIT'=Symbol('Key.'dsnam'.'i) then leave dsn=dsn'.'key.dsnam.i ft=key.dsnam.i /*always the last one */ end if aft<>'' then ft=aft dsn="'"Delstr(dsn,1,1)"'" say 'Receiving 'dsn' from 'Key.fuid.1' at 'Key.tnode.1'.' /*extract info from first IEBCOPY cntl record*/ if '00CA6D0F'<>c2x(substr(rec,3,4)) then croak('Not unloaded IEBCOPY format') ublksize=c2d(substr(rec,09,2)) ulrecl=c2d(substr(rec,11,2)) urecfm=substr(rec,13,1) urecfm=translate(urecfm,'F','90'x) if ^datatype(urecfm,a) then croak('Unsupported record format in original PDS') /*tblksize=c2d(substr(rec,17,2))*/ /*now read control record 2*/ rec=ReadRec() s=3 /*skip IDTF stuff*/ extent.0=c2d(Substr(rec,s,1)) /*number of extents in this deb*/ s=s+16 /*assume last trk of first extent is number of trks per cyl */ trkscyl=1+c2d(Substr(rec,s+12,2)) r=0 do i=1 to extent.0 start=c2d(Substr(rec,s+6,2))*trkscyl+c2d(Substr(rec,s+8,2)) end=c2d(Substr(rec,s+10,2))*trkscyl+c2d(Substr(rec,s+12,2)) size=end-start extent.i.1=start extent.i.2=end extent.i.3=r /*rel start*/ extent.i.4=size+r /*rel end */ r=1+r+size /*adjust relative for next pass*/ s=s+16 end /*read and decode directory records */ do forever rec=delstr(ReadRec(),1,2) /*discard IDTF stuff */ dblks=length(rec)%276 /*276=256+12 byte count+8 byte key*/ do i=1 to dblks db=Substr(rec,1+(i-1)*276,276) s=23 /*ignore count,key,1st hwd*/ dblen=c2d(substr(db,22,1)) do while (s'FFFFFFFFFFFFFFFF'x) t=c2x(Substr(db,s+8,3)) /*drop name in ttr indexed bucket*/ dirm.t=Substr(db,s,8) ul=c2d(Bitand(Substr(db,s+11,1),'1F'x)) s=s+12+ul*2 end end /*if key = high value, this was last dir block */ if substr(db,13,8)='FFFFFFFFFFFFFFFF'x then leave end /*directory loop*/ /*read next record, the first data record, so it is in buffer when */ /*we return to dodata. */ rec=ReadRec() return /*First*/ /*********************************************************************/ /* Create a file name, and open file */ /*********************************************************************/ Open: arg cchhr memcount=memcount+1 ttr=ttr(cchhr) fn=dirm.ttr if afn<>'' then fn=afn say 'Processing 'dirm.ttr' as 'fn ft afm 'SET CMSTYPE HT' 'ERASE 'FN FT AFM 'SET CMSTYPE RT' /*execio will do the actual open...*/ open=1 return /*Open*/ /*********************************************************************/ /*********************************************************************/ /* Close files, etc. */ /*********************************************************************/ Eof: 'CP CLOSE 00C' exit 0 return /*Eof*/ /*********************************************************************/ /*Read a logical IDTF record. */ /*********************************************************************/ ReadRec: Procedure expose chbuf chbufp len=Charin('CARD',,1) flg=Charin('CARD',,1) rec=len||flg||Charin('CARD',,c2d(len)-2) do while '00'x=Bitand(flg,'40'x) /*end segment yet?*/ len=Charin('CARD',,1) flg=Charin('CARD',,1) ttt=Charin('CARD',,c2d(len)-2) rec=rec||ttt end return rec /*ReadRec*/ /*********************************************************************/ /*********************************************************************/ /*issue an error message, close reader, and exit */ /*********************************************************************/ Croak: Procedure parse arg msg,ec say "Error:" msg 'CP CLOSE RDR HOLD' say 'Error: File has been left in your reader' if ec='' then ec=8 exit ec /*Croak*/ /*********************************************************************/ /*********************************************************************/ /*Extract a specific key from a control record */ /*********************************************************************/ GetKey: Procedure parse arg rec,key if Substr(rec,3,6)='INMR02' then rec=delstr(rec,1,12) else rec=delstr(rec,1,8) do while length(rec)>0 tkey=nextkey(rec) if key=substr(tkey,1,2) then return tkey rec=delstr(rec,1,min(length(rec),length(tkey))) end return '' /*key not found, if we fall out of loop*/ /*Getkey*/ /*********************************************************************/ /*********************************************************************/ /*Return the next complete key in the argument buffer. */ /*********************************************************************/ NextKey: Procedure parse arg buf count=c2d(Substr(buf,3,2)) len=4 do i=1 to count len=len+2+c2d(substr(buf,len+1,2)) end return left(buf,len) /*Getkey*/ /*********************************************************************/ /*********************************************************************/ /* Closely models the REXX language definition for the CHARIN */ /* builtin function, which is not implemented in VM. \ */ /* STREAM is ignored; all I/O is to current file in card reader. */ /* This is considered a transient stream, so START is ignored. */ /*********************************************************************/ Charin: Procedure Expose chbuf chbufp Arg stream,start,length,. chars='' do while length>0 if chbufp>length(chbuf) then do 'EXECIO 1 CARD (VAR CHBUF' if rc<>0 then croak('Error on card reader, rc='rc) chbufp=1 end l=min(length,1+length(chbuf)-chbufp) if length<1 then leave chars=chars||substr(chbuf,chbufp,l) chbufp=chbufp+l length=length-l end /*main read loop*/ return chars /*CHARIN*/ /*********************************************************************/ /*********************************************************************/ /* Syntax error handler */ /*********************************************************************/ SYNTAX: ERROR: parse source . . pgmfn pgmft . SAY format(sigl,6) '+++' Sourceline(sigl) SAY 'Error' rc 'running 'pgmfn pgmft', line' sigl':' errortext(rc) croak('Execution halted; see above',20000+rc) return /*Syntax*/ /*********************************************************************/ /*********************************************************************/ /* Establish symbolic names for key fields */ /*********************************************************************/ setnames: fack ='1026' /*acknowledgement requested */ fnode='1021' /*origin node */ ftime='1024' /*origin time */ fuid ='1012' /*origin user id */ utiln='1028' /*utility name */ dsnam='0002' /*dataset name (in pieces) */ tuid ='1002' /*target user id */ tnode='1001' /*target node */ return /*setnames*/ /*********************************************************************/ /*********************************************************************/ /* Change a absolute volume CCHHR to a relative TTR */ /*********************************************************************/ TTR: procedure expose extent. trkscyl arg cchhr cc=c2d(substr(cchhr,1,2)) hh=c2d(substr(cchhr,3,2)) at=cc*trkscyl+hh do i=1 to extent.0 if (at>=extent.i.1)&(at<=extent.i.2) then leave end return right(d2x(at-extent.i.1+extent.i.3)c2x(right(cchhr,1)),6,'0') /*TTR*/ /*********************************************************************/ /*********************************************************************/ /* Print a string in hex. */ /*********************************************************************/ Hexdump: procedure parse arg s p='' do i=1 to length(s) by 4 p=p c2x(Substr(s,i,4)) if 13=i//16 then p=p' ' if 29=i//32 then do;say p;p='';end; end if p<>'' then say p return /*Hexdump*/ /*********************************************************************/ /*********************************************************************/ /* Display call syntax */ /*********************************************************************/ Help: vmfclear say 'RECPDS is designed to receive a spool file transmitted from an MVS' say 'system via the TSO TRANSMIT command where the dataset being sent ' say 'is partitioned.' say say 'Invocation syntax: RECPDS spool# fn ft fm' say say 'where "spool#" is the number of a file in your reader;' say '"fn", "ft", and "fm" are optional overrides; if not supplied:' say ' spool# = first file in your reader.' say ' fn = member name from PDS.' say ' ft = last node of MVS dataset name.' say ' fm = A' say say 'Use * as a placeholder for omitted arguments;' say 'Ex: "RECPDS 43 * XYZ B" will receive file number 43, use the PDS' say 'member name(s), but force the file type and mode to "XYZ" and "B".' say say 'If there are multiple members in the input stream, overriding "fn"' say 'will cause each file to overlay the previous one; you will end up' say 'with the only the last member.' say exit 0 /*Help*/ /*********************************************************************/