OS/2 Shareware BBS: 8 Other/08-Other.zip/HPTDEM.ZIP/HSEND.RXC

Text File | 1992-06-22 | 8KB | 189 lines

/* HSEND.CMD    (c) Copyright HeteroGenius Systems Ltd 1991     */
CALL RXFUNCADD "TBDISPL","HRXDLL","HRXDSPT"
CALL RXFUNCADD "DISPLAY","HRXDLL","HRXDSPL"
CALL RXFUNCADD "HRXQFILE","HRXDLL","HRXQFILE"
CALL RXFUNCADD "HRXPAUSE","HRXDLL","HRXPAUSE"
CALL RXFUNCADD "HRXVGET","HRXDLL","HRXVPRF"
CALL RXFUNCADD "HRXVPUT","HRXDLL","HRXVPRF"
CALL RXFUNCADD "HAPSEND","HDPDDM","HDPFTSR"
/* Get the profile variables */
profvars = "hostlu sfmask senddsn fclass repopt zscfl"
CALL HRXVGET "HPTSO",profvars
oldpath = DIRECTORY()
/* Get the LU name override */
ARG lu .
IF lu <> '' THEN hostlu = lu
msg = ''
DO m=1 BY 0
   /* Prompt the user for file mask */
   cursor = "SFMASK"
   DO UNTIL msg = ''
      CALL DISPLAY "HBPSNDP1",cursor,msg; msg = ''
      IF result = "END" THEN LEAVE m
      IF result <> "ENTER" THEN EXIT 12
      IF sfmask = '' THEN DO
         msg = 'ENTER FILE SPECIFICATION'
         cursor = "SFMASK"; ITERATE; END
   END /* DO */
   pattern = sfmask
   DO w=1 BY 0
      /* Obtain a list of matching files */
      CALL HRXQFILE pattern,"FS" /* sets fsfnum,fspath,fsmaxl,
                fsfile.k,fssize.k,fslmdate.k,fslmtime.k */
      IF fsfnum = 0 THEN DO
         msg = 'NO MATCHING FILES'; ITERATE m; END
      /* Display the table of file names */
      IF fsmaxl > 12 THEN tbpanel = "HBPSNDT2"
      ELSE tbpanel = "HBPSNDT1"
      pattern = fspath
      path = FILESPEC('D',pattern) || FILESPEC('P',pattern)
      CALL DIRECTORY path
      tbselect. = ''
      next = 1; msg = ''; pause = 'N'
      DO FOREVER
         IF pause = 'Y' THEN DO; CALL HRXPAUSE "***"; pause = 'N'; END
         CALL TBDISPL tbpanel,fsfnum,next,,msg,pattern; msg = ''
         IF result = "END" THEN LEAVE w
         IF result <> "ENTER" THEN EXIT 12
         prompt = 'Y'
         firstsel = 0
         /* Search the array for selected files */
         DO k = 1 TO fsfnum
            IF tbselect.k <> ' ' THEN DO
               next = k
               IF firstsel = 0 THEN firstsel = k
               sendlfn = path || fsfile.k
               subdir = (fssize.k = '<DIR>')
            END
            SELECT
            WHEN tbselect.k = 'S' THEN DO
               IF ¬subdir THEN DO
                  msg = "'S' IS ONLY VALID FOR DIRECTORIES"
                  LEAVE k; END
               pattern = sendlfn || '\*.*'
               ITERATE w
            END /* WHEN tbselect.k = 'S' */
            WHEN tbselect.k = 'J' THEN DO
               IF subdir THEN DO
                  msg = "'J' CANNOT BE USED ON A DIRECTORY"
                  LEAVE k; END
               prompt = 'Y'
               IF pause='Y' THEN DO;CALL HRXPAUSE "***";pause='N';END
               CALL HSBMT sendlfn,,hostlu
               IF result = 0 THEN pause = 'Y'
               IF result <> 0 & result <> 4 THEN DO
                  msg = "SUBMIT FAILED"; pause = 'Y'; LEAVE k; END
               tbselect.k = '*'
            END /* WHEN tbselect.k = 'J' */
            WHEN tbselect.k = 'T' THEN DO
               IF prompt = 'Y' & pause='Y' THEN DO
                  CALL HRXPAUSE "***"; pause = 'N'; END
               cursor = "SENDDSN"
               /* Prompt the user for LU name and host dsname */
               IF prompt = 'Y' THEN DO UNTIL msg = ''
                  CALL DISPLAY "HBPSNDP2",cursor,msg; msg = ''
                  IF result = "END" THEN DO
                     tbselect.k = ''; LEAVE k; END
                  IF result <> "ENTER" THEN EXIT 12
                  IF prompt <> 'Y' & prompt <> 'N' THEN DO
                     msg = 'INVALID PROMPT VALUE. SPECIFY Y OR N'
                     cursor = "PROMPT"; ITERATE; END
                  IF hostlu = ''  THEN DO
                     msg = "ENTER HOST NAME"
                     cursor = "HOSTLU"; ITERATE; END
                  IF senddsn = '' THEN DO
                     msg = "ENTER HOST DATASET NAME"
                     cursor = "SENDDSN"; ITERATE; END
                  rdsname = dsnbuild(sendlfn,senddsn)
                  IF VERIFY(rdsname,'<>|&"','M') <> 0 THEN DO
                     msg = 'INVALID CHARACTERS IN HOST DATASET NAME'
                     cursor = "SENDDSN"; ITERATE; END
                  x = TRANSLATE(LEFT(fclass,1))
                  SELECT
                  WHEN x = 'T' THEN fclass = 'TEXT'
                  WHEN x = 'B' THEN fclass = 'BINARY'
                  OTHERWISE
                     msg = 'INVALID FILE CLASS'
                     cursor = "FCLASS"; ITERATE
                  END
                  x = TRANSLATE(LEFT(repopt,1))
                  SELECT
                  WHEN x = 'R' THEN repopt = 'REPL'
                  WHEN x = 'N' THEN repopt = 'NOREPL'
                  WHEN x = 'L' THEN repopt = 'LATER'
                  OTHERWISE
                     msg = 'INVALID REPLACE OPTION'
                     cursor = "REPOPT"; ITERATE
                  END
               END /* IF */
               ELSE rdsname = dsnbuild(sendlfn,senddsn)
               IF subdir THEN
                  /* Send all files in directory to the host */
                  CALL senddir hostlu,sendlfn,senddsn,fclass,repopt
               ELSE DO
                  /* Send one file to the host */
                  SAY 'HAPSEND' hostlu sendlfn rdsname fclass repopt
                  CALL HAPSEND hostlu,sendlfn,rdsname,fclass,repopt
               END
               pause = 'Y'
               IF result <> 0 & result <> 4 THEN DO
                  msg = "SEND FAILED"; LEAVE k; END
               tbselect.k = '*'
            END /* WHEN tbselect.k = 'T' */
            OTHERWISE
               NOP
            END /* SELECT */
         END k
         IF k > fsfnum THEN next = firstsel
      END /* DO FOREVER */
   END w
END m
CALL DIRECTORY oldpath
CALL HRXVPUT "HPTSO",profvars
EXIT 0
/* Procedure to send all files in subdirectory */
senddir: PROCEDURE EXPOSE msg
   PARSE ARG hostlu,dirname,senddsn,fclass,repopt
   /* Obtain a list of files in directory */
   CALL HRXQFILE dirname'\*.*',"SS" /* sets ssfnum,sspath,ssmaxl,
                ssfile.k,sssize.k,sslmdate.k,sslmtime.k */
   /* Send each file to the remote LU */
   DO k = 1 TO ssfnum
      IF sssize.k <> '<DIR>' THEN DO
         sendlfn = dirname'\'ssfile.k
         rdsname = dsnbuild(sendlfn,senddsn)
         SAY 'HAPSEND' hostlu sendlfn rdsname fclass repopt
         ft = HAPSEND(hostlu,sendlfn,rdsname,fclass,repopt)
         IF ft <> 0 & ft <> 4 THEN RETURN ft
      END
   END
   RETURN 0
/* Procedure to build host dsname from local filename */
dsnbuild: PROCEDURE
   PARSE ARG lfname,senddsn
   drive = FILESPEC('D',lfname); path = FILESPEC('P',lfname)
   PARSE VAR path '\' qual1 '\' qual2 '\' qual3 '\' qual4 '\',
        qual5 '\' qual6 '\' qual7 '\' qual8 '\' qual9 '\'
   PARSE VALUE FILESPEC('N',lfname) WITH fname '.' ftype
   rdsname = replace(senddsn,"&DRIVE",drive)
   rdsname = replace(rdsname,"&PATH",path)
   rdsname = replace(rdsname,"&FNAME",fname)
   rdsname = replace(rdsname,"&FTYPE",ftype)
   rdsname = replace(rdsname,"&QUAL1",qual1)
   rdsname = replace(rdsname,"&QUAL2",qual2)
   rdsname = replace(rdsname,"&QUAL3",qual3)
   rdsname = replace(rdsname,"&QUAL4",qual4)
   rdsname = replace(rdsname,"&QUAL5",qual5)
   rdsname = replace(rdsname,"&QUAL6",qual6)
   rdsname = replace(rdsname,"&QUAL7",qual7)
   rdsname = replace(rdsname,"&QUAL8",qual8)
   rdsname = replace(rdsname,"&QUAL9",qual9)
   RETURN rdsname
/* Procedure to replace one substring by another */
replace: PROCEDURE
   PARSE ARG source,string1,string2
   PARSE UPPER ARG usource,ustring1
   i = POS(ustring1,usource)
   IF i = 0 THEN RETURN source
   RETURN INSERT(string2,DELSTR(source,i,LENGTH(string1)),i-1)