home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
kermit.columbia.edu
/
kermit.columbia.edu.tar
/
kermit.columbia.edu
/
modcomp
/
ssend.
< prev
next >
Wrap
Text File
|
1987-01-25
|
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