Columbia Kermit/kermit.zip/modcomp/ssend.

Text File | 2020-01-01 | 10KB | 311 lines

      SUBROUTINE SSEND (ALIN)
C
C     ****************************************************************
C
C              KERMIT for the MODCOMP MAXIV operating system
C
C        Compliments of:
C
C                         SETPOINT, Inc.
C                      10245 Brecksville Rd.
C                      Brecksville, Ohio 44141
C
C
C      KERMIT is a copyrighted protocol of Columbia Univ. The authors
C      of this version hereby grant permission to copy this software
C      provided that it is not used for an explicitly commercial
C      purpose and that proper credit be given. SETPOINT, Inc. makes
C      no warranty whatsoever regarding the accuracy of this package
C      and will assume no liability resulting from it's use.
C
C     ****************************************************************
C
C     Abstract:  Send a file or group of files to a remote Kermit.
C
C
C     MODIFICATION HISTORY
C
C     BY            DATE     REASON            PROGRAMS AFFECTED
C
C     ****************************************************************
C
C     Author:  Rick Burke           Version: A.0    Date: Aug-86
C
C     Calling Parameters:
C
C     R    ALIN         - Command line with name of file or group
C                         of files to be sent.
C
C     ****************************************************************
C
C     Messages generated by this module :  None
C
C     ****************************************************************
C
C     Subroutines called directly :  ASSGN4, CTA4, ISCAN, ISHFT
C                                    PACK, POSUSL, READ4, REW4,
C                                    SENDSW, SKIPBL, WAIT, WEOF4
C
C     ****************************************************************
C
C     Files referenced :  None
C
C     ****************************************************************
C
C     Local variable definitions :
C
C     A1           - Character pointer into ALIN
C     BEGENT       - Index to 1st entry in directory sector
C     BKPTR        - Pointer to previous sector
C     CH           - UFT number for directory reads
C     ERR          - Error indicator for CTA4
C     FILEOK       - Success flag from POSUSL, file was found
C     FRPTR        - Forward pointer to next directory sector
C     I            - Index variable
C     IDX          - Index variable
C     IND          - Error indicator from WAIT call
C     JUSL         - CAN code of directory name to be sent to
C                    the remote Kermit
C     MXENT        - Number of directory entries per sector
C     SCRLUN       - LUN of file for file name list
C     SCRUFT       - UFT number of file to be used for temporary
C                    storage of file names to be sent to remote
C     SECTOR       - Directory partition file position index to read
C     STATUS       - Function value returned by SENDSW
C     TCOUNT       - Index variable
C     X            - Dummy argument required by SENDSW function
C     DIRBUF(128)  - Buffer for directory sector
C     DIRNAM(132)  - Buffer for ASCII name of directory to send
C     ENTRY(9,14)  - Table of directory entries for a sector
C     FILNME(4)    - ASCII file name (packed 2 chars per word)
C     TLINE(12)    - File name buffer (unpacked ASCII)
C
C     ****************************************************************
C
C     Commons referenced :  KER, KERPAR, and UFTTBL local commons
C
C     ****************************************************************
C
C     (*$END.DOCUMENT*)
C
C     ****************************************************************
C     *                                                              *
C     *         D I M E N S I O N   S T A T E M E N T S              *
C     *                                                              *
C     ****************************************************************
C
      IMPLICIT INTEGER (A-Z)
      INTEGER*2   ALIN(1),     DIRNAM(132), ENTRY(9,14), DIRBUF(128)
      INTEGER*2   FILNME(4),   TLINE(12)
C
C     ****************************************************************
C     *                                                              *
C     *         T Y P E   S T A T E M E N T S                        *
C     *                                                              *
C     ****************************************************************
C
      LOGICAL*2   FILEOK
C
C     ****************************************************************
C     *                                                              *
C     *         C O M M O N   S T A T E M E N T S                    *
C     *                                                              *
C     ****************************************************************
C
      INCLUDE USL/KERCOM
      INCLUDE USL/KERPMC
      INCLUDE USL/UFTTBC
C
C     ****************************************************************
C     *                                                              *
C     *         E Q U I V A L E N C E   S T A T E M E N T S          *
C     *                                                              *
C     ****************************************************************
C
      EQUIVALENCE (DIRBUF(1),BKPTR),        (DIRBUF(2),FRPTR)
      EQUIVALENCE (DIRBUF(3),ENTRY(1,1))
C
C     ****************************************************************
C     *                                                              *
C     *         D A T A   S T A T E M E N T S                        *
C     *                                                              *
C     ****************************************************************
C
      DATA        MXENT /14/,  SCRUFT / 9/
C
C     ****************************************************************
C
C     Code starts here :
C
C----->  If we're in HOST mode, issue binary READ.
C
      IF (HOSTON .NE. YES) GO TO 5
      CURCHN = 1
      CALL READ4 (IUFT(1,4),BLIN(1,CURCHN),132,.FALSE.)
    5 CONTINUE
C
C----->  Initialize the logical unit for the file name list.
C
      SCRLUN = IUFT(2,SCRUFT)
C
C----->  Position character pointer to start of file specification.
C
      A1 = 1
      CALL SKIPBL(ALIN,A1)
      IF (ALIN(A1) .NE. LF) GO TO 10
      WRITE (LOCALO,1000)
 1000 FORMAT (' PROPER FORMAT IS "SEND FILENAME" OR ',/
     >        ' "SEND @FILENAME"')
      RETURN
   10 CONTINUE
C
C----->  Check for "@" as next character.  If so then the request is
C----->  to send an entire directory of files.
C
      IF (ALIN(A1) .NE. ATSIGN) GO TO 90
      A1 = A1 + 1
C
C----->  Extract the directory name from the command line and
C----->  convert it to CAN code.
C
      DIRNAM(1) = 4Z2020
      DIRNAM(2) = 4Z2020
      DIRNAM(3) = 4Z2020
      CALL PACK (ALIN(A1),DIRNAM)
      JUSL = ISCAN (DIRNAM)
C
C----->  Set up the UFT for reading the directory.
C
      CH = 7
      IUFT(3,CH) = 4Z9400
      CALL ASSGN4 (IUFT(1,CH),JUSL)
C
C----->  Rewind the scratch file that will contain the names of the
C----->  files to be sent.
C
      CALL REW4 (IUFT(1,SCRUFT))
C
C----->  Read a directory and put the file names into the scratch file.
C
      FRPTR = 0
   20 CONTINUE
      IUFT(4,CH) = FRPTR
      SECTOR = FRPTR
      CALL READ4 (IUFT(1,CH),DIRBUF,256)
      IF (SECTOR .NE. 0) GO TO 30
C
C----->  Was the directory found?
C
      IF (BKPTR .EQ. -1) GO TO 30
      WRITE (1,1010) (DIRNAM(I),I=1,4)
 1010 FORMAT (' DIRECTORY NOT FOUND ON ',3A2)
      RETURN
C
C----->  Loop through this sector to find a file entry.
C
   30 CONTINUE
      BEGENT = 1
      IF (SECTOR .EQ. 0) BEGENT = 2
      DO 40 IDX=BEGENT,MXENT
      IF (ENTRY(1,IDX) .NE.      0 .AND.
     >    ENTRY(1,IDX) .NE. 4ZFEFE      ) GO TO 50
   40 CONTINUE
C
C----->  Entry not found, go read the next sector unless this
C----->  sector was the last (FRPTR = -1).
C
      IF (FRPTR .LT. 0) GO TO 80
      GO TO 20
   50 CONTINUE
      IF (ENTRY(1,IDX) .EQ. 4ZFFFF) GO TO 80
      IF (ENTRY(1,IDX) .EQ.      0 .OR.
     >    ENTRY(1,IDX) .EQ. 4ZFEFE     ) GO TO 75
C
C----->  Got a file entry, so convert the file
C----->  name into the unpacked ASCII string for
C----->  DPUTLIN.
C
      CALL CTA4 (ENTRY(1,IDX),TLINE(1),ERR)
      CALL CTA4 (ENTRY(2,IDX),TLINE(4),ERR)
      CALL CTA4 (ENTRY(3,IDX),TLINE(7),ERR)
      DO 55 I=1,9
      TLINE(I) = ISHFT (TLINE(I),-8)
   55 CONTINUE
C
C----->  Remove trailing blanks.
C
      DO 60 I=1,9
      TCOUNT = 10 - I
      IF (TLINE(TCOUNT) .NE.     0 .AND.
     >    TLINE(TCOUNT) .NE. BLANK      ) GO TO 70
   60 CONTINUE
      TCOUNT = 0
   70 CONTINUE
C
C----->  Add CR/EOS at the end.
C
      TLINE(TCOUNT+1) = LF
      TLINE(TCOUNT+2) = EOS
C
C----->  Write the file name out to the scratch file.
C
      FILNME(1) = '  '
      FILNME(2) = '  '
      FILNME(3) = '  '
      FILNME(4) = '  '
      CALL PACK (TLINE,FILNME)
      WRITE (SCRLUN,1050) FILNME
 1050 FORMAT (4A2)
   75 CONTINUE
C
C----->  Loop back to get another file name.
C
      IDX = IDX + 1
      IF (IDX .LE. MXENT) GO TO 50
      GO TO 20
   80 CONTINUE
C
C----->  Write an EOF after the last name in the scratch partition.
C
      CALL WEOF4 (IUFT(1,SCRUFT))
      GO TO 110
   90 CONTINUE
C
C----->  Write the file name in the command line to the scratch
C----->  partition.
C
C----->  First, try to position to the file.
C
      CH = 7
      CALL ASSGN4 (IUFT(1,CH),SUSL)
      FILNME(1) = '  '
      FILNME(2) = '  '
      FILNME(3) = '  '
      FILNME(4) = '  '
      CALL PACK (ALIN(A1),FILNME)
      CALL POSUSL (IUFT(2,CH),FILNME,FILEOK)
      IF (FILEOK) GO TO 100
      WRITE (LOCALO,1020)
 1020 FORMAT (' REQUESTED SOURCE FILE NOT FOUND.',//)
      RETURN
  100 CONTINUE
C
C----->  Put the file name at the beginning of the scratch.
C
      CALL REW4 (IUFT(1,SCRUFT))
      WRITE (SCRLUN,1050) FILNME
      CALL WEOF4 (IUFT(1,SCRUFT))
  110 CONTINUE
C
C----->  Send the file(s) to the remote Kermit.
C
      CALL REW4 (IUFT(1,SCRUFT))
      CALL WAIT (DELAY,2,IND)
      STATUS = SENDSW (X)
      IF (STATUS .EQ. YES) WRITE (LOCALO,1030)
 1030 FORMAT (' FILE TRANSFER COMPLETED.',//)
      IF (STATUS .NE. YES) WRITE (LOCALO,1040)
 1040 FORMAT (' FILE TRANSFER FAILED.',//)
      RETURN
      END