/*                                                     rexx
 PIPE subroutine, write to dataset, create if it do not exist.

 If  the  dataset  do  not  exist,  it  will  be  created  using  the
 allocation  parms  or  values  derived  from  analyzing  the  input.

 Syntax  PIPE2DS [>|>>] dataset alloc-parms [RTNV]|[RTDDN]
   >|>> write or append, default is > (write).
   Dataset is  the name of the  new or existing dataset  to write to.
   The dataset can be a temporary name like &&TEMP. To access such a
   dataset afterwards, you must use the RTDDN parameter (see below).
   Allocation  parms are  the same  as  for the  BPXWDYN program,  so
   things   like  'LIKE(datasetname)   CYL   SPACE(1,1)'  is   valid.
   RTNV returns the generated allocation parameter plus RTDSN(dataset)
   and RTDDN(ddname).
   RTNND will return the ddname for a temporary dataset, to be used
   like this:
     "PIPE stem data. | pipe2ds &&temp rtddn | var dd"
     "PIPE stem data2. | >> ddname="dd
      . . .
     "PIPE TSO FREE DD("dd")"
   TRKS may be used instead of TRACKS
   LRECL(*) will for RECFM V and set lrecl = length of widest record+4.
*/
 parse value '0 0 32756 DSORG(PS)' with dbytes dmaxrl dminrl adir pspcu
 parse value copies('0 ',30) with $exist $allocd $temp $ispds $large $log .
 iblksz=600000
 $log=0

 arg p
 if left(p,1)<>'>' then p='>' p
 parse var p acc ds ap
 parse var ds pdsn'('pmbr')' .
 $temp  = (left(ds,1)='&')
 $ispds = (pmbr<>'')
 n=wordpos('LOG',ap)
 if n>0 then do
   $log=1
   ap=delword(ap,n,1)
 end
 call logit 'parm:' p
 call logit 'ap:  'ap

 /* pull parameter data */
 ap=' 'ap
 parse var ap . ' LIKE('plike')'    . 0 . ' DD('pdd')' . ,
            0 . ' RECFM('prf')'     . 0 . ' LRECL('prl')' .,
            0 . ' UNIT('punit')'    . 0 . ' DSORG('pdso')' .,
            0 . ' DIR('pdir')'      . 0 . ' SPACE('pspc')' .,
            0 . ' RTNV '  +0 prtnv  . 0 . ' RTDDN '  +0 prtddn .,
            0 . ' DSNTYPE('dstyp')' .
 prf=strip(left(prf,1))
 if prl='*' then prf='V'    /* force recfm V when lrecl * */
 if pos(' TR',ap)>0 then pspcu='TRACKS'
 if pos(' CY',ap)>0 then pspcu='CYL'
 if $ispds then adir='DIR('word(pdir 40,1)') DSORG(PO)'
 call logit 'Parm rf('prf') rl('prl')'

 /* Load data to stem */
 n=0
 dbytes=0
 do forever
   "readto rec"
   if rc<>0 then leave
   if prf='V' then rec=strip(rec,'t')
   else if prl<>'' then rec=left(rec,prl)
   dmaxrl=max(dmaxrl,length(rec))
   dminrl=min(dminrl,length(rec))
   dbytes=dbytes+length(rec)
   n=n+1
   data.n=rec
   if dbytes<iblksz then iterate
   $large=1
   leave
 end
 data.0=n
 drf=word('V F',(dmaxrl=dminrl)+1)
 drl=dmaxrl
 if prl='*' then prl=drl+4  /* add RDW */
 dtrks = (dbytes%40000)+1
 call logit 'Data rf('drf') rl('drl')'

 /* determine dataset status (SYSDSN/LISTDSI don't work here) */
 if $temp=0 then do
   $allocd = (BpxWdyn('info da('pdsn')')=0)
   if $allocd then $exist=1
   else do
     dd=''
     $exist= (BpxWdyn('alloc da('ds') shr rtddn(dd)')=0)
     if dd<>'' then zz=BpxWdyn('free dd('dd')')
   end
 end
 if $temp | $exist=0 | $ispds then acc='>'  /* force rewrite, not append */

 /* if exsting pds or allocated dataset or append then just write */
 if ($ispds & $exist) | $allocd | acc='>>' then do
   "callpipe stem data. |" acc requote(ds)
   cc=rc
   if cc<>0 then "output" cc acc ds 'datacount' data.0
   if $large then call Writerest  requote(ds)
   return cc
 end

 /* can/must we delete the dataset beforehand ? */
 $doalloc=($temp | $exist=0)
 if $exist then do
   cc=BpxWdyn('alloc da('ds') old delete rtddn(dd)')
   if cc<>0 then exit 999
   cc=BpxWdyn('free dd('dd')')
   $doalloc=1
 end

 Call LogIt 'large:' $large,
            'temp:' $temp,
            'exist' $exist,
            'allocate:' $doalloc

 /* build allocation parameter, create dataset */
 if $doalloc then do
   if $large & pspcu='' then,
     parse value 'CYL 2,20' with pspcu pspc  /* force large space */
   if $temp then alcp='DA('ds') NEW DELETE'
   else          alcp='DA('ds') NEW CATALOG'
   if plike<>'' then alcp=alcp 'LIKE('plike')'
   if pdd  <>'' then alcp=alcp 'DD('pdd') REUSE'
   arf  = word(prf drf,1)
   arl  = word(prl drl,1)
   if arf='V' & prl='' then arl=27994      /* half-track */
   if dstyp<>'' then alcp=alcp 'DSNTYPE('dstyp')'
   alcp = alcp word(pspcu 'TRACKS',1) 'UNIT('word(punit 'SYSDA',1)')',
          'SPACE('word(pspc dtrks+$ispds','dtrks,1)')',
          'RECFM('arf',B) LRECL('arl') BLKSIZE(0)' adir
   cc=bpxwdyn('alloc' alcp 'rtddn(xdd) rtdsn(xds)')
   Call Logit 'allocate' alcp 'rc' cc
   if cc<>0 then do
     "output create" cc space(alcp)
     exit 1
   end
   if $temp=0 then zz=bpxwdyn('free dd('xdd')')
 end

 /* finally write to dataset */
 if $temp then tgt="ddname="xdd
 else          tgt=requote(ds)
 Call LogIt 'base stem data.' acc tgt
 "callpipe stem data. |" acc tgt
 if $large then do
   Call LogIt 'rest stem data.' acc tgt
   rc=Writerest(tgt)
 end
 cc=rc

 /* return info               */
 if prtnv<>''  then "output" space(alcp 'RTDSN('xds') RTDDN('xdd')')
 if prtddn<>'' | $temp then "output" xdd
 Call LogIt 'bytes written' dbytes
 exit cc

Requote:
 if arg(1)='' then return ''
 return "'"translate(strip(strip(arg(1)),"b","'"))"'"
Unquote: return translate(strip(strip(arg(1)),"b","'"))

/* this is where it becomes horribly inefficient, but at least
   it shouldn't abend with space related issues                    */
Writerest:
 Call LogIt 'writerest'
 arg wrtgt
 n=0
 wbytes=0
 do forever
   "readto rec"
   if rc<>0 then leave
   if prf='V' then rec=strip(rec,'t')
   else if prl<>'' then rec=left(rec,prl)
   wbytes=wbytes+length(rec)
   n=n+1
   data.n=rec
   if wbytes<iblksz then iterate
   dbytes=dbytes+wbytes
   Call LogIt 'write block'
   data.0=n
   "callpipe stem data. | >>" wrtgt
   n=0
   wbytes=0
 end
 if n=0 then return rc
 dbytes=dbytes+wbytes
 data.0=n
 "callpipe stem data. | >>" wrtgt
 return rc

LogIt:
 if $log=0 then return 0
 "callpipe literal" arg(1) "| >> ddname=log"
 return  0