MODULE KERFIL (IDENT = '3.3.119', ADDRESSING_MODE(EXTERNAL = GENERAL, NONEXTERNAL = GENERAL)) = BEGIN ! !++ ! FACILITY: ! KERMIT-32 Microcomputer to mainframe file transfer utility. ! ! ABSTRACT: ! KERFIL contains all of the file processing for KERMIT-32. This ! module contains the routines to input/output characters to files ! and to open and close the files. ! ! ENVIRONMENT: ! VAX/VMS user mode. ! ! AUTHOR: Robert C. McQueen, CREATION DATE: 28-March-1983 ! !-- %SBTTL 'Table of Contents' %SBTTL 'Revision History' !++ ! ! 1.0.000 By: Robert C. McQueen On: 28-March-1983 ! Create this module. ! 1.0.001 By: Robert C. McQueen On: 4-April-1983 ! Remove checks for in the input data stream. ! ! 1.0.002 By: Robert C. McQueen On: 31-May-1983 ! Fix a bad check in wildcard processing. ! ! 1.0.003 By: Nick Bush On: 13-June-1983 ! Add default file spec of .;0 so that wild-carded ! file types don't cause all version of a file to ! be transferred. ! ! 1.0.004 By: Robert C. McQueen On: 20-July-1983 ! Strip off the parity bit on the compares for incoming ASCII ! files. ! ! 1.2.005 By: Robert C. McQueen On: 15-August-1983 ! Attempt to improve the GET%FILE and make it smaller. ! Also start the implementation of the BLOCK file processing. ! ! 2.0.006 Release VAX/VMS Kermit-32 version 2.0 ! ! 2.0.016 By: Nick Bush On: 4-Dec-1983 ! Change how binary files are written to (hopefully) improve ! the performance. We will now use 510 records and only ! write out the record when it is filled (instead of writing ! one record per packet). This should cut down on the overhead ! substantially. ! ! 2.0.017 By: Nick Bush On: 9-Dec-1983 ! Fix processing for VFC format files. Also fix GET_ASCII ! for PRN and FTN record types. Change GET_ASCII so that ! 'normal' CR records get sent with trailing CRLF's instead ! of record. That was confusing too many people. ! ! 2.0.022 By: Nick Bush On: 15-Dec-1983 ! Add Fixed record size (512 byte) format for writing files. ! This can be used for .EXE files. Also clean up writing ! ASCII files so that we don't lose any characters. ! ! 2.0.024 By: Robert C. McQueen On: 19-Dec-1983 ! Delete FILE_DUMP. ! ! 2.0.026 By: Nick Bush On: 3-Jan-1983 ! Add options for format of file specification to be ! sent in file header packets. Also type out full file ! specification being sent/received instead of just ! the name we are telling the other end to use. ! ! 2.0.030 By: Nick Bush On: 3-Feb-1983 ! Add the capability of receiving a file with a different ! name than given by KERMSG. The RECEIVE and GET commands ! now really are different. ! ! 2.0.035 By: Nick Bush On: 8-March-1984 ! Add LOG SESSION command to set a log file for CONNECT. ! While we are doing so, clean up the command parsing a little ! so that we don't have as many COPY_xxx routines. ! ! 2.0.036 By: Nick Bush On: 15-March-1984 ! Fix PUT_FILE to correctly handle carriage returns which are ! not followed by line feeds. Count was being decremented ! Instead of incremented. ! ! 2.0.040 By: Nick Bush On: 22-March-1984 ! Fix processing of FORTRAN carriage control to handle lines ! which do not contain the carriage control character (i.e., zero ! length records). Previously, this type of record was sending ! infinite nulls. ! ! 3.0.045 Start of version 3. ! ! 3.0.046 By: Nick Bush On: 29-March-1984 ! Fix debugging log file to correctly set/clear file open ! flag. Also make log files default to .LOG. ! ! 3.0.050 By: Nick Bush On: 2-April-1984 ! Add SET SERVER_TIMER to determine period between idle naks. ! Also allow for a routine to process file specs before ! FILE_OPEN uses them. This allows individual sites to ! restrict the format of file specifications used by Kermit. ! ! 3.1.053 By: Robert C. McQueen On: 9-July-1984 ! Fix FORTRAN carriage control processing to pass along ! any character from the carriage control column that is ! not really carriage control. ! ! Start version 3.2 ! ! 3.2.067 By: Robert C. McQueen On: 8-May-1985 ! Use $GETDVIW instead of $GETDVI. ! ! 3.2.070 By: David Stevens On: 16-July-1985 ! Put "Sending: " prompt into NEXT_FILE routine, to make ! VMS KERMIT similar to KERMIT-10. ! ! 3.2.077 By: Robert McQueen On: 8-May-1986 ! Fix FORTRAN CC once and for all (I hope). ! ! Start of version 3.3 ! ! 3.3.105 By: Robert McQueen On: 8-July-1986 ! Do some clean up and attempt to fix LINK-W-TRUNC errors ! from a BLISS-32 bug. ! ! 3.3.106 By: Robert McQueen On: 8-July-1986 ! Fix problem of closing a fixed file and losing data. ! ! 3.3.111 By: Robert McQueen On: 2-Oct-1986 ! Make Kermit-32 not eat the parity from a CR if a LF doesn't ! follow it when writing an ASCII file. ! ! 3.3.112 JHW0001 Jonathan H. Welch, 28-Apr-1988 12:11 ! Fix the message generated in NEXT_FILE so that the ! filenames displayed (i.e. Sending: foo.bar;1 as foo.bar) ! are always terminated by a null (ASCIZ). ! ! 3.3.117 JHW006 Jonathan H. Welch, 12-May-1988 ! Calls to LIB$SIGNAL with multiple arguments were ! not coded correctly. For calls with multiple arguments ! an argument count was added. ! Minor changes to KERM_HANDLER to make use of the changed ! argument passing method. ! ! 3.3.118 JHW010 Jonathan H. Welch, 23-Apr-1990 09:42 ! Added SET FILE BLOCKSIZE nnn (where nnn is the record size ! in bytes) command for incoming BINARY and FIXED file transfers. ! If no blocksize has been specified the old behavior (510 byte ! records plus 2 bytes (for CR/LF) for BINARY files and 512 ! byte records for FIXED files will be used. ! Also modified SHOW FILE to display record size when appropriate. ! ! 3.3.119 JHW015 Jonathan H. Welch, 16-Jul-1990 15:30 ! Fixed the logic in GET_ASCII which was causing an infinite ! loop for files with print file carriage control. !-- %SBTTL 'Forward definitions' FORWARD ROUTINE LOG_PUT, ! Write a buffer out DUMP_BUFFER, ! Worker routine for FILE_DUMP. GET_BUFFER, ! Routine to do $GET GET_ASCII, ! Get an ASCII character GET_BLOCK, ! Get a block character FILE_ERROR : NOVALUE; ! Error processing routine %SBTTL 'Require/Library files' ! ! INCLUDE FILES: ! LIBRARY 'SYS$LIBRARY:STARLET'; REQUIRE 'KERCOM.REQ'; %SBTTL 'Macro definitions' ! ! MACROS: ! %SBTTL 'Literal symbol definitions' ! ! EQUATED SYMBOLS: ! ! ! Various states for reading the data from the file ! LITERAL F_STATE_PRE = 0, ! Prefix state F_STATE_PRE1 = 1, ! Other prefix state F_STATE_DATA = 2, ! Data processing state F_STATE_POST = 3, ! Postfix processing state F_STATE_POST1 = 4, ! Secondary postfix processing state F_STATE_MIN = 0, ! Min state number F_STATE_MAX = 4; ! Max state number ! ! Buffer size for log file ! LITERAL LOG_BUFF_SIZE = 256; ! Number of bytes in log file buffer %SBTTL 'Local storage' ! ! OWN STORAGE: ! OWN SEARCH_FLAG, ! Can/cannot do $SEARCH DEV_CLASS, ! Type of device we are reading EOF_FLAG, ! End of file reached. FILE_FAB : $FAB_DECL, ! FAB for file processing FILE_NAM : $NAM_DECL, ! NAM for file processing FILE_RAB : $RAB_DECL, ! RAB for file processing FILE_XABFHC : $XABFHC_DECL, ! XAB for file processing FILE_MODE, ! Mode of file (reading/writing) FILE_REC_POINTER, ! Pointer to the record information FILE_REC_COUNT, ! Count of the number of bytes REC_SIZE : LONG, ! Record size REC_ADDRESS : LONG, ! Record address FIX_SIZE : LONG, ! Fixed control region size FIX_ADDRESS : LONG, ! Address of buffer for fixed control region EXP_STR : VECTOR [CH$ALLOCATION (NAM$C_MAXRSS)], RES_STR : VECTOR [CH$ALLOCATION (NAM$C_MAXRSS)], RES_STR_D : BLOCK [8, BYTE]; ! Descriptor for the string %SBTTL 'Global storage' ! ! Global storage: ! GLOBAL file_blocksize, ! Block size of for BINARY and FIXED files. file_blocksize_set, ! 0=user has not specified a blocksize, 1=user has specified a blocksize FILE_TYPE, ! Type of file being xfered FILE_DESC : BLOCK [8, BYTE]; ! File name descriptor %SBTTL 'External routines and storage' ! ! EXTERNAL REFERENCES: ! ! ! Storage in KERMSG ! EXTERNAL ALT_FILE_SIZE, ! Number of characters in FILE_NAME ALT_FILE_NAME : VECTOR [CH$ALLOCATION (MAX_FILE_NAME)], ! Storage FILE_SIZE, ! Number of characters in FILE_NAME FILE_NAME : VECTOR [CH$ALLOCATION (MAX_FILE_NAME)], TY_FIL, ! Flag that file names are being typed CONNECT_FLAG, ! Indicator of whether we have a terminal to type on FIL_NORMAL_FORM; ! File specification type ! ! Routines in KERTT ! EXTERNAL ROUTINE TT_OUTPUT : NOVALUE; ! Force buffered output ! ! System libraries ! EXTERNAL ROUTINE LIB$GET_VM : ADDRESSING_MODE (GENERAL), LIB$FREE_VM : ADDRESSING_MODE (GENERAL), LIB$SIGNAL : ADDRESSING_MODE (GENERAL) NOVALUE; %SBTTL 'File processing -- FILE_INIT - Initialization' GLOBAL ROUTINE FILE_INIT : NOVALUE = !++ ! FUNCTIONAL DESCRIPTION: ! ! This routine will initialize some of the storage in the file processing ! module. ! ! CALLING SEQUENCE: ! ! FILE_INIT(); ! ! INPUT PARAMETERS: ! ! None. ! ! IMPLICIT INPUTS: ! ! None. ! ! OUTPUT PARAMETERS: ! ! None. ! ! IMPLICIT OUTPUTS: ! ! None. ! ! COMPLETION CODES: ! ! None. ! ! SIDE EFFECTS: ! ! None. ! !-- BEGIN FILE_TYPE = FILE_ASC; file_blocksize = 512; file_blocksize_set = 0; ! Now set up the file specification descriptor FILE_DESC [DSC$B_CLASS] = DSC$K_CLASS_S; FILE_DESC [DSC$B_DTYPE] = DSC$K_DTYPE_T; FILE_DESC [DSC$A_POINTER] = FILE_NAME; FILE_DESC [DSC$W_LENGTH] = 0; EOF_FLAG = FALSE; END; ! End of FILE_INIT %SBTTL 'GET_FILE' GLOBAL ROUTINE GET_FILE (CHARACTER) = !++ ! FUNCTIONAL DESCRIPTION: ! ! This routine will return a character from the input file. ! The character will be stored into the location specified by ! CHARACTER. ! ! CALLING SEQUENCE: ! ! GET_FILE (LOCATION_TO_STORE_CHAR); ! ! INPUT PARAMETERS: ! ! LOCATION_TO_STORE_CHAR - This is the address to store the character ! into. ! ! IMPLICIT INPUTS: ! ! None. ! ! OUTPUT PARAMETERS: ! ! Character stored into the location specified. ! ! IMPLICIT OUTPUTS: ! ! None. ! ! COMPLETION CODES: ! ! True - Character stored into the location specified. ! False - End of file reached. ! ! SIDE EFFECTS: ! ! None. ! !-- BEGIN ! ! Define the various condition codes that we check for in this routine ! EXTERNAL LITERAL KER_EOF; ! End of file LOCAL STATUS; ! Random status values IF .EOF_FLAG THEN RETURN KER_EOF; SELECTONE .FILE_TYPE OF SET [FILE_ASC, FILE_BIN, FILE_FIX] : STATUS = GET_ASCII (.CHARACTER); [FILE_BLK] : STATUS = GET_BLOCK (.CHARACTER); TES; RETURN .STATUS; END; ! End of GET_FILE %SBTTL 'GET_ASCII - Get a character from an ASCII file' ROUTINE GET_ASCII (CHARACTER) = !++ ! FUNCTIONAL DESCRIPTION: ! ! CALLING SEQUENCE: ! ! INPUT PARAMETERS: ! ! None. ! ! IMPLICIT INPUTS: ! ! None. ! ! OUPTUT PARAMETERS: ! ! None. ! ! IMPLICIT OUTPUTS: ! ! None. ! ! COMPLETION CODES: ! ! KER_EOF - End of file encountered ! KER_ILLFILTYP - Illegal file type ! KER_NORMAL - Normal return ! ! SIDE EFFECTS: ! ! None. ! !-- BEGIN ! ! Status codes that are returned by this module ! EXTERNAL LITERAL KER_EOF, ! End of file encountered KER_ILLFILTYP, ! Illegal file type KER_NORMAL; ! Normal return OWN CC_COUNT, ! Count of the number of CC things to output CC_TYPE; ! Type of carriage control being processed. LOCAL STATUS, ! For status values RAT; %SBTTL 'GET_FTN_FILE_CHARACTER - Get a character from an Fortran carriage control file' ROUTINE GET_FTN_FILE_CHARACTER (CHARACTER) = !++ ! FUNCTIONAL DESCRIPTION: ! ! This routine will get a character from a FORTRAN carriage control file. ! A FORTRAN carriage control file is one with FAB$M_FTN on in the FAB$B_RAT ! field. ! ! FORMAL PARAMETERS: ! ! CHARACTER - Address of where to store the character ! ! IMPLICIT INPUTS: ! ! CC_TYPE - Carriage control type ! ! IMPLICIT OUTPUTS: ! ! CC_TYPE - Updated if this is the first characte of the record ! ! COMPLETION_CODES: ! ! System service or Kermit status code ! ! SIDE EFFECTS: ! ! Next buffer can be read from the data file. !-- BEGIN ! ! Dispatch according to the state of the file being read. Beginning of ! record, middle of record, end of record ! WHILE TRUE DO CASE .FILE_FAB[FAB$L_CTX] FROM F_STATE_MIN TO F_STATE_MAX OF SET ! ! Here at the beginning of a record. We must read the buffer from the file ! at this point. Once the buffer is read we must then determine what to do ! with the FORTRAN carriage control that at the beginning of the buffer. ! [F_STATE_PRE ]: BEGIN ! ! Local variables ! LOCAL STATUS; ! Status returned by the ! GET_BUFFER routine ! ! Get the buffer ! STATUS = GET_BUFFER (); ! Get a buffer from the system IF (NOT .STATUS) ! If this call failed OR (.STATUS EQL KER_EOF) ! or we got an EOF THEN RETURN .STATUS; ! Just return the status ! ! Here with a valid buffer full of data all set to be decoded ! IF .FILE_REC_COUNT LEQ 0 ! If nothing, use a space THEN ! for the carriage control CC_TYPE = %C' ' ELSE BEGIN CC_TYPE = CH$RCHAR_A (FILE_REC_POINTER); FILE_REC_COUNT = .FILE_REC_COUNT - 1; END; ! ! Dispatch on the type of carriage control that we are processing ! SELECTONE .CC_TYPE OF SET ! ! All of these just output: ! ! [CHR_NUL, %C'+'] : BEGIN FILE_FAB [FAB$L_CTX] = F_STATE_DATA; END; ! ! This outputs: ! ! [%C'$', %C' '] : BEGIN .CHARACTER = CHR_LFD; FILE_FAB [FAB$L_CTX] = F_STATE_DATA; RETURN KER_NORMAL; END; ! ! This outputs: ! ! [%C'0'] : BEGIN .CHARACTER = CHR_LFD; FILE_FAB [FAB$L_CTX] = F_STATE_PRE1; RETURN KER_NORMAL; END; ! ! This outputs: !
! [%C'1'] : BEGIN .CHARACTER = CHR_FFD; FILE_FAB [FAB$L_CTX] = F_STATE_DATA; RETURN KER_NORMAL; END; ! ! If we don't know the type of carriage control, then just return the ! character we read as data and set the carriage control to be space ! to fool the post processing of the record ! [OTHERWISE] : BEGIN .CHARACTER = .CC_TYPE; ! Return the character CC_TYPE = %C' '; ! Treat as space FILE_REC_POINTER = CH$PLUS(.FILE_REC_POINTER,-1); FILE_REC_COUNT = .FILE_REC_COUNT + 1; FILE_FAB [FAB$L_CTX] = F_STATE_DATA; RETURN KER_NORMAL END; TES; END; ! ! Here to add the second LF for the double spacing FORTRAN carriage control ! [F_STATE_PRE1 ]: BEGIN .CHARACTER = CHR_LFD; FILE_FAB [FAB$L_CTX] = F_STATE_DATA; RETURN KER_NORMAL; END; ! ! Here to read the data of the record ! [F_STATE_DATA]: BEGIN ! ! Here to read the data of the record and return it to the caller ! This section can only return KER_NORMAL to the caller ! IF .FILE_REC_COUNT LEQ 0 ! Anything left in the buffer THEN FILE_FAB [FAB$L_CTX] = F_STATE_POST ! No, do post processing ELSE BEGIN .CHARACTER = CH$RCHAR_A (FILE_REC_POINTER); ! Get a character FILE_REC_COUNT = .FILE_REC_COUNT - 1; ! Decrement the count RETURN KER_NORMAL; ! Give a good return END; END; ! ! Here to do post processing of the record. At this point we are going ! to store either nothing as the post fix, a carriage return for overprinting ! or a carriage return and then a line feed in the POST1 state. ! [F_STATE_POST ]: BEGIN SELECTONE .CC_TYPE OF SET ! ! This stat is for no carriage control on the record. This is for ! 'null' carriage control (VMS manual states: "Null carriage control ! (print buffer contents.)" and for prompt carriage control. ! [CHR_NUL, %C'$' ]: BEGIN FILE_FAB [FAB$L_CTX] = F_STATE_PRE END; ! ! This is the normal state, that causes the postfix for the data to be ! a line feed. ! [%C'0', %C'1', %C' ', %C'+' ]: BEGIN .CHARACTER = CHR_CRT; FILE_FAB [FAB$L_CTX] = F_STATE_PRE; RETURN KER_NORMAL END; TES; END; ! ! Here if we are in a state that this routine doesn't set. Just assume that ! something screwed up and give an illegal file type return to the caller ! [INRANGE, OUTRANGE]: RETURN KER_ILLFILTYP; TES END; %SBTTL 'GET_ASCII - Main logic' RAT = .FILE_FAB [FAB$B_RAT] AND ( NOT FAB$M_BLK); IF .DEV_CLASS EQL DC$_MAILBOX THEN RAT = FAB$M_CR; ! Mailbox needs CR's WHILE TRUE DO BEGIN SELECTONE .RAT OF SET [FAB$M_FTN ]: BEGIN RETURN GET_FTN_FILE_CHARACTER (.CHARACTER) END; [FAB$M_PRN, FAB$M_CR] : CASE .FILE_FAB [FAB$L_CTX] FROM F_STATE_MIN TO F_STATE_MAX OF SET [F_STATE_PRE] : BEGIN STATUS = GET_BUFFER (); IF NOT .STATUS OR .STATUS EQL KER_EOF THEN RETURN .STATUS; SELECTONE .RAT OF SET [FAB$M_CR] : BEGIN FILE_FAB [FAB$L_CTX] = F_STATE_DATA; END; [FAB$M_PRN] : BEGIN LOCAL TEMP_POINTER; TEMP_POINTER = CH$PTR (.FILE_RAB [RAB$L_RHB]); CC_COUNT = CH$RCHAR_A (TEMP_POINTER); CC_TYPE = CH$RCHAR_A (TEMP_POINTER); IF .CC_COUNT<7, 1> EQL 0 THEN BEGIN IF .CC_COUNT<0, 7> NEQ 0 THEN BEGIN .CHARACTER = CHR_LFD; CC_COUNT = .CC_COUNT - 1; IF .CC_COUNT GTR 0 THEN FILE_FAB [FAB$L_CTX] = F_STATE_PRE1 ELSE FILE_FAB [FAB$L_CTX] = F_STATE_DATA; RETURN KER_NORMAL; END ELSE FILE_FAB [FAB$L_CTX] = F_STATE_DATA; END ELSE BEGIN SELECTONE .CC_COUNT<5, 2> OF SET [%B'00'] : BEGIN .CHARACTER = .CC_COUNT<0, 5>; FILE_FAB [FAB$L_CTX] = F_STATE_DATA; RETURN KER_NORMAL; END; [%B'10'] : BEGIN .CHARACTER = .CC_COUNT<0, 5> + 128; FILE_FAB [FAB$L_CTX] = F_STATE_DATA; RETURN KER_NORMAL; END; [OTHERWISE, %B'11'] : RETURN KER_ILLFILTYP; TES; END; END; TES; END; [F_STATE_PRE1] : IF .RAT EQL FAB$M_PRN THEN BEGIN .CHARACTER = CHR_LFD; CC_COUNT = .CC_COUNT - 1; IF .CC_COUNT LEQ 0 THEN FILE_FAB [FAB$L_CTX] = F_STATE_DATA; RETURN KER_NORMAL; END ELSE RETURN KER_ILLFILTYP; [F_STATE_DATA] : BEGIN IF .FILE_REC_COUNT LEQ 0 THEN FILE_FAB [FAB$L_CTX] = F_STATE_POST ELSE BEGIN .CHARACTER = CH$RCHAR_A (FILE_REC_POINTER); FILE_REC_COUNT = .FILE_REC_COUNT - 1; RETURN KER_NORMAL; END; END; [F_STATE_POST] : BEGIN SELECTONE .RAT OF SET [FAB$M_CR] : BEGIN .CHARACTER = CHR_CRT; FILE_FAB [FAB$L_CTX] = F_STATE_POST1; ! So we get a line feed RETURN KER_NORMAL; END; [FAB$M_PRN] : BEGIN IF .CC_TYPE<7, 1> EQL 0 THEN BEGIN IF .CC_TYPE<0, 7> NEQ 0 THEN BEGIN .CHARACTER = CHR_LFD; CC_COUNT = .CC_TYPE; FILE_FAB [FAB$L_CTX] = F_STATE_POST1; RETURN KER_NORMAL; END ELSE FILE_FAB [FAB$L_CTX] = F_STATE_PRE; END ELSE BEGIN SELECTONE .CC_TYPE<5, 2> OF SET [%B'00'] : BEGIN .CHARACTER = .CC_TYPE<0, 5>; FILE_FAB [FAB$L_CTX] = F_STATE_PRE; RETURN KER_NORMAL; END; [%B'10'] : BEGIN .CHARACTER = .CC_TYPE<0, 5> + 128; FILE_FAB [FAB$L_CTX] = F_STATE_PRE; RETURN KER_NORMAL; END; [OTHERWISE, %B'11'] : RETURN KER_ILLFILTYP; TES; END; END; TES; ! End SELECTONE .RAT END; [F_STATE_POST1] : IF .RAT EQL FAB$M_PRN THEN BEGIN .CHARACTER = CHR_LFD; CC_COUNT = .CC_COUNT - 1; IF .CC_COUNT LEQ -1 THEN BEGIN .CHARACTER = CHR_CRT; ! FILE_FAB [FAB$L_CTX] = F_STATE_DATA; FILE_FAB [FAB$L_CTX] = F_STATE_PRE; END; RETURN KER_NORMAL; END ELSE ! ! Generate line feed after CR for funny files ! IF (.RAT EQL FAB$M_CR) THEN BEGIN .CHARACTER = CHR_LFD; ! Return a line feed FILE_FAB [FAB$L_CTX] = F_STATE_PRE; ! Next we get data RETURN KER_NORMAL; END ELSE RETURN KER_ILLFILTYP; TES; ! End of CASE .STATE [OTHERWISE] : BEGIN WHILE .FILE_REC_COUNT LEQ 0 DO BEGIN STATUS = GET_BUFFER (); IF NOT .STATUS OR .STATUS EQL KER_EOF THEN RETURN .STATUS; END; FILE_REC_COUNT = .FILE_REC_COUNT - 1; .CHARACTER = CH$RCHAR_A (FILE_REC_POINTER); RETURN KER_NORMAL; END; TES; ! End of SELECTONE .RAT END; ! End WHILE TRUE DO loop RETURN KER_ILLFILTYP; ! Shouldn't get here END; ! End of GET_ASCII %SBTTL 'GET_BLOCK - Get a character from a BLOCKed file' ROUTINE GET_BLOCK (CHARACTER) = !++ ! FUNCTIONAL DESCRIPTION: ! ! This routine will return the next byte from a blocked file. This ! routine will use the $READ RMS call to get the next byte from the ! file. This way all RMS header information can be passed to the ! other file system. ! ! CALLING SEQUENCE: ! ! STATUS = GET_BLOCK(CHARACTER); ! ! INPUT PARAMETERS: ! ! CHARACTER - Address to store the character in. ! ! IMPLICIT INPUTS: ! ! REC_POINTER - Pointer into the record. ! REC_ADDRESS - Address of the record. ! REC_COUNT - Count of the number of bytes left in the record. ! ! OUPTUT PARAMETERS: ! ! None. ! ! IMPLICIT OUTPUTS: ! ! None. ! ! COMPLETION CODES: ! ! KER_NORMAL - Got a byte ! KER_EOF - End of file gotten. ! KER_RMS32 - RMS error ! ! SIDE EFFECTS: ! ! None. ! !-- BEGIN ! ! Status codes returned by this module ! EXTERNAL LITERAL KER_RMS32, ! RMS error encountered KER_EOF, ! End of file encountered KER_NORMAL; ! Normal return LOCAL STATUS; ! Random status values WHILE .FILE_REC_COUNT LEQ 0 DO BEGIN STATUS = $READ (RAB = FILE_RAB); IF NOT .STATUS THEN IF .STATUS EQL RMS$_EOF THEN BEGIN EOF_FLAG = TRUE; RETURN KER_EOF; END ELSE BEGIN FILE_ERROR (.STATUS); EOF_FLAG = TRUE; RETURN KER_RMS32; END; FILE_REC_POINTER = CH$PTR (.REC_ADDRESS); FILE_REC_COUNT = .FILE_RAB [RAB$W_RSZ]; END; FILE_REC_COUNT = .FILE_REC_COUNT - 1; .CHARACTER = CH$RCHAR_A (FILE_REC_POINTER); RETURN KER_NORMAL; END; ! End of GET_BLOCK %SBTTL 'GET_BUFFER - Routine to read a buffer.' ROUTINE GET_BUFFER = !++ ! FUNCTIONAL DESCRIPTION: ! ! This routine will read a buffer from the disk file. It will ! return various status depending if there was an error reading ! the disk file or if the end of file is reached. ! ! CALLING SEQUENCE: ! ! STATUS = GET_BUFFER (); ! ! INPUT PARAMETERS: ! ! None. ! ! IMPLICIT INPUTS: ! ! None. ! ! OUTPUT PARAMETERS: ! ! None. ! ! IMPLICIT OUTPUTS: ! ! FILE_REC_POINTER - Pointer into the record. ! FILE_REC_COUNT - Count of the number of bytes in the record. ! ! COMPLETION CODES: ! ! KER_NORMAL - Got a buffer ! KER_EOF - End of file reached. ! KER_RMS32 - RMS error ! ! SIDE EFFECTS: ! ! None. ! !-- BEGIN ! ! The following are the various status values returned by this routien ! EXTERNAL LITERAL KER_NORMAL, ! Normal return KER_EOF, ! End of file KER_RMS32; ! RMS error encountered LOCAL STATUS; ! Random status values STATUS = $GET (RAB = FILE_RAB); IF NOT .STATUS THEN IF .STATUS EQL RMS$_EOF THEN BEGIN EOF_FLAG = TRUE; RETURN KER_EOF; END ELSE BEGIN FILE_ERROR (.STATUS); EOF_FLAG = TRUE; RETURN KER_RMS32; END; FILE_REC_POINTER = CH$PTR (.REC_ADDRESS); FILE_REC_COUNT = .FILE_RAB [RAB$W_RSZ]; RETURN KER_NORMAL; END; %SBTTL 'PUT_FILE' GLOBAL ROUTINE PUT_FILE (CHARACTER) = !++ ! FUNCTIONAL DESCRIPTION: ! ! This routine will store a character into the record buffer ! that we are building. It will output the buffer to disk ! when the end of line characters are found. ! ! CALLING SEQUENCE: ! ! STATUS = PUT_FILE(Character); ! ! INPUT PARAMETERS: ! ! Character - Address of the character to output in the file. ! ! IMPLICIT INPUTS: ! ! None. ! ! OUTPUT PARAMETERS: ! ! Status - True if no problems writing the character ! False if there were problems writing the character. ! ! IMPLICIT OUTPUTS: ! ! None. ! ! COMPLETION CODES: ! ! None. ! ! SIDE EFFECTS: ! ! None. ! !-- BEGIN ! ! Completion codes ! EXTERNAL LITERAL KER_REC_TOO_BIG, ! Record too big KER_NORMAL; ! Normal return ! ! Local variables ! OWN SAVED_CHARACTER : UNSIGNED BYTE; ! Character we may have to ! write later on LOCAL STATUS; ! Random status values SELECTONE .FILE_TYPE OF SET [FILE_ASC] : BEGIN ! ! If the last character was a carriage return and this is a line feed, ! we will just dump the record. Otherwise, if the last character was ! a carriage return, output both it and the current one. ! IF .FILE_FAB [FAB$L_CTX] NEQ F_STATE_DATA THEN BEGIN IF (.CHARACTER AND %O'177') EQL CHR_LFD THEN BEGIN FILE_FAB [FAB$L_CTX] = F_STATE_DATA; RETURN DUMP_BUFFER (); END ELSE BEGIN IF .FILE_REC_COUNT GEQ .REC_SIZE THEN BEGIN LIB$SIGNAL (KER_REC_TOO_BIG); RETURN KER_REC_TOO_BIG; END; CH$WCHAR_A (.SAVED_CHARACTER, FILE_REC_POINTER); ! Store the carriage return we deferred FILE_REC_COUNT = .FILE_REC_COUNT + 1; FILE_FAB [FAB$L_CTX] = F_STATE_DATA; ! Back to normal data END; END; ! ! Here when last character was written to the file normally. Check if ! this character might be the end of a record (or at least the start of ! end. ! IF (.CHARACTER AND %O'177') EQL CHR_CRT THEN BEGIN SAVED_CHARACTER = .CHARACTER; ! Save the character for later FILE_FAB [FAB$L_CTX] = F_STATE_POST; ! Remember we saw this RETURN KER_NORMAL; ! And delay until next character END; IF .FILE_REC_COUNT GEQ .REC_SIZE THEN BEGIN LIB$SIGNAL (KER_REC_TOO_BIG); RETURN KER_REC_TOO_BIG; END; FILE_REC_COUNT = .FILE_REC_COUNT + 1; CH$WCHAR_A (.CHARACTER, FILE_REC_POINTER); END; [FILE_BIN, FILE_FIX] : BEGIN IF .FILE_REC_COUNT GEQ .REC_SIZE THEN BEGIN STATUS = DUMP_BUFFER (); IF NOT .STATUS THEN BEGIN LIB$SIGNAL (.STATUS); RETURN .STATUS; END; END; FILE_REC_COUNT = .FILE_REC_COUNT + 1; CH$WCHAR_A (.CHARACTER, FILE_REC_POINTER); END; [FILE_BLK] : BEGIN IF .FILE_REC_COUNT GEQ .REC_SIZE THEN BEGIN FILE_RAB [RAB$W_RSZ] = .FILE_REC_COUNT; STATUS = $WRITE (RAB = FILE_RAB); FILE_REC_COUNT = 0; FILE_REC_POINTER = CH$PTR (.REC_ADDRESS); END; FILE_REC_COUNT = .FILE_REC_COUNT + 1; CH$WCHAR_A (.CHARACTER, FILE_REC_POINTER); END; TES; RETURN KER_NORMAL; END; ! End of PUT_FILE %SBTTL 'DUMP_BUFFER - Dump the current record to disk' ROUTINE DUMP_BUFFER = !++ ! FUNCTIONAL DESCRIPTION: ! ! This routine will dump the current record to disk. It doesn't ! care what type of file you are writing, unlike FILE_DUMP. ! ! CALLING SEQUENCE: ! ! STATUS = DUMP_BUFFER(); ! ! INPUT PARAMETERS: ! ! None. ! ! IMPLICIT INPUTS: ! ! None. ! ! OUTPUT PARAMETERS: ! ! None. ! ! IMPLICIT OUTPUTS: ! ! None. ! ! COMPLETION CODES: ! ! KER_NORMAL - Output went ok. ! KER_RMS32 - RMS-32 error. ! ! SIDE EFFECTS: ! ! None. ! !-- BEGIN ! ! Completion codes returned: ! EXTERNAL LITERAL KER_NORMAL, ! Normal return KER_RMS32; ! RMS-32 error ! ! Local variables ! LOCAL STATUS; ! Random status values ! ! First update the record length ! FILE_RAB [RAB$W_RSZ] = .FILE_REC_COUNT; ! ! Now output the record to the file ! STATUS = $PUT (RAB = FILE_RAB); ! ! Update the pointers first ! FILE_REC_COUNT = 0; FILE_REC_POINTER = CH$PTR (.REC_ADDRESS); ! ! Now determine if we failed attempting to write the record ! IF NOT .STATUS THEN BEGIN FILE_ERROR (.STATUS); RETURN KER_RMS32 END; RETURN KER_NORMAL END; ! End of DUMP_BUFFER %SBTTL 'OPEN_READING' ROUTINE OPEN_READING = !++ ! FUNCTIONAL DESCRIPTION: ! ! This routine will open a file for reading. It will return either ! true or false to the called depending on the success of the ! operation. ! ! CALLING SEQUENCE: ! ! status = OPEN_READING(); ! ! INPUT PARAMETERS: ! ! None. ! ! IMPLICIT INPUTS: ! ! None. ! ! OUTPUT PARAMETERS: ! ! None. ! ! IMPLICIT OUTPUTS: ! ! None. ! ! COMPLETION CODES: ! ! KER_NORMAL - Normal return ! KER_RMS32 - RMS error encountered ! ! SIDE EFFECTS: ! ! None. ! !-- BEGIN ! ! Completion codes returned: ! EXTERNAL LITERAL KER_NORMAL, ! Normal return KER_RMS32; ! RMS-32 error LOCAL STATUS; ! Random status values ! ! We now have an expanded file specification that we can use to process ! the file. ! IF .FILE_TYPE NEQ FILE_BLK THEN BEGIN $FAB_INIT (FAB = FILE_FAB, FAC = GET, FOP = NAM, RFM = STM, NAM = FILE_NAM, XAB = FILE_XABFHC); END ELSE BEGIN $FAB_INIT (FAB = FILE_FAB, FAC = (GET, BIO), FOP = NAM, RFM = STM, NAM = FILE_NAM, XAB = FILE_XABFHC); END; $XABFHC_INIT (XAB = FILE_XABFHC); STATUS = $OPEN (FAB = FILE_FAB); IF (.STATUS NEQ RMS$_NORMAL AND .STATUS NEQ RMS$_KFF) THEN BEGIN FILE_ERROR (.STATUS); RETURN KER_RMS32; END; ! ! Now allocate a buffer for the records ! REC_SIZE = (IF .FILE_TYPE EQL FILE_BLK THEN 512 ELSE .FILE_XABFHC [XAB$W_LRL]); IF .REC_SIZE EQL 0 THEN REC_SIZE = MAX_REC_LENGTH; STATUS = LIB$GET_VM (REC_SIZE, REC_ADDRESS); ! ! Determine if we need a buffer for the fixed control area ! FIX_SIZE = .FILE_FAB [FAB$B_FSZ]; IF .FIX_SIZE NEQ 0 THEN BEGIN STATUS = LIB$GET_VM (FIX_SIZE, FIX_ADDRESS); END; ! ! Initialize the RAB for the $CONNECT RMS call ! $RAB_INIT (RAB = FILE_RAB, FAB = FILE_FAB, RAC = SEQ, ROP = NLK, UBF = .REC_ADDRESS, USZ = .REC_SIZE); IF .FIX_SIZE NEQ 0 THEN FILE_RAB [RAB$L_RHB] = .FIX_ADDRESS; ! Store header address STATUS = $CONNECT (RAB = FILE_RAB); IF NOT .STATUS THEN BEGIN FILE_ERROR (.STATUS); RETURN KER_RMS32; END; FILE_REC_COUNT = -1; FILE_FAB [FAB$L_CTX] = F_STATE_PRE; RETURN KER_NORMAL; END; ! End of OPEN_READING %SBTTL 'FILE_OPEN' GLOBAL ROUTINE FILE_OPEN (FUNCTION) = !++ ! FUNCTIONAL DESCRIPTION: ! ! This routine will open a file for reading or writing depending on ! the function that is passed this routine. It will handle wildcards ! on the read function. ! ! CALLING SEQUENCE: ! ! status = FILE_OPEN(FUNCTION); ! ! INPUT PARAMETERS: ! ! FUNCTION - Function to do. Either FNC_READ or FNC_WRITE. ! ! IMPLICIT INPUTS: ! ! FILE_NAME and FILE_SIZE set up with the file name and the length ! of the name. ! ! OUTPUT PARAMETERS: ! ! None. ! ! IMPLICIT OUTPUTS: ! ! FILE_NAME and FILE_SIZE set up with the file name and the length ! of the name. ! ! COMPLETION CODES: ! ! KER_NORMAL - File opened correctly. ! KER_RMS32 - Problem processing the file. ! KER_INTERNALERR - Internal Kermit-32 error. ! ! SIDE EFFECTS: ! ! None. ! !-- BEGIN ! ! Completion codes returned: ! EXTERNAL LITERAL KER_NORMAL, ! Normal return KER_INTERNALERR, ! Internal error KER_RMS32; ! RMS-32 error EXTERNAL ROUTINE TT_TEXT : NOVALUE; ! Output an ASCIZ string EXTERNAL ROUTINE ! ! This external routine is called to perform any checks on the file ! specification that the user wishes. It must return a true value ! if the access is to be allowed, and a false value (error code) if ! access is to be denied. The error code may be any valid system wide ! error code, any Kermit-32 error code (KER_xxx) or a user specific code, ! provided a message file defining the error code is loaded with Kermit-32. ! ! The routine is called as: ! ! STATUS = USER_FILE_CHECK ( FILE NAME DESCRIPTOR, READ/WRITE FLAG) ! ! The file name descriptor points to the file specification supplied by ! the user. The read/write flag is TRUE if the file is being read, and ! false if it is being written. ! USER_FILE_CHECK : ADDRESSING_MODE(GENERAL) WEAK; LOCAL STATUS, ! Random status values ITMLST : VECTOR [4, LONG], ! For GETDVI call SIZE : WORD; ! Size of resulting file name ! ! Assume we can do searches ! SEARCH_FLAG = TRUE; DEV_CLASS = DC$_DISK; ! Assume disk file ! ! Now do the function dependent processing ! FILE_MODE = .FUNCTION; FILE_DESC [DSC$W_LENGTH] = .FILE_SIZE; ! Length of file name ! ! Call user routine (if any) ! IF USER_FILE_CHECK NEQ 0 THEN BEGIN STATUS = USER_FILE_CHECK (FILE_DESC, %REF (.FILE_MODE EQL FNC_READ)); IF NOT .STATUS THEN BEGIN LIB$SIGNAL (.STATUS); RETURN .STATUS; END; END; ! ! Select the correct routine depending on if we are reading or writing. ! SELECTONE .FUNCTION OF SET [FNC_READ] : BEGIN ! ! Determine device type ! ITMLST [0] = DVI$_DEVCLASS^16 + 4; ! Want device class ITMLST [1] = DEV_CLASS; ! Put it there ITMLST [2] = ITMLST [2]; ! Put the size here ITMLST [3] = 0; ! End the list STATUS = $GETDVIW (DEVNAM = FILE_DESC, ITMLST = ITMLST); ! ! If not a disk, can't do search ! IF .STATUS AND .DEV_CLASS NEQ DC$_DISK THEN SEARCH_FLAG = FALSE; ! ! Now set up the FAB with the information it needs. ! $FAB_INIT (FAB = FILE_FAB, FOP = NAM, FNA = FILE_NAME, FNS = .FILE_SIZE, NAM = FILE_NAM, DNM = '.;0'); ! ! Now initialize the NAM block ! $NAM_INIT (NAM = FILE_NAM, RSA = RES_STR, RSS = NAM$C_MAXRSS, ESA = EXP_STR, ESS = NAM$C_MAXRSS); ! ! First parse the file specification. ! STATUS = $PARSE (FAB = FILE_FAB); IF NOT .STATUS THEN BEGIN FILE_ERROR (.STATUS); RETURN KER_RMS32; END; IF .SEARCH_FLAG THEN BEGIN STATUS = $SEARCH (FAB = FILE_FAB); IF NOT .STATUS THEN BEGIN FILE_ERROR (.STATUS); RETURN KER_RMS32; END; END; ! ! We now have an expanded file specification that we can use to process ! the file. ! STATUS = OPEN_READING (); ! Open the file IF NOT .STATUS THEN RETURN .STATUS; ! If we couldn't, pass error back ! ! Tell user what name we ended up with for storing the file ! IF ( NOT .CONNECT_FLAG) AND .TY_FIL THEN BEGIN IF .FILE_NAM [NAM$B_RSS] GTR 0 THEN BEGIN CH$WCHAR (CHR_NUL, CH$PTR (.FILE_NAM [NAM$L_RSA], .FILE_NAM [NAM$B_RSL])); TT_TEXT (.FILE_NAM [NAM$L_RSA]); END ELSE BEGIN CH$WCHAR (CHR_NUL, CH$PTR (.FILE_NAM [NAM$L_ESA], .FILE_NAM [NAM$B_ESL])); TT_TEXT (.FILE_NAM [NAM$L_ESA]); END; TT_TEXT (UPLIT (%ASCIZ' as ')); END; END; ! End of [FNC_READ] [FNC_WRITE] : BEGIN SELECTONE .FILE_TYPE OF SET [FILE_ASC] : BEGIN $FAB_INIT (FAB = FILE_FAB, FAC = PUT, FNA = FILE_NAME, FNS = .FILE_SIZE, FOP = (MXV, CBT, SQO, TEF), NAM = FILE_NAM, ORG = SEQ, RFM = VAR, RAT = CR); END; [FILE_BIN] : BEGIN $FAB_INIT (FAB = FILE_FAB, FAC = PUT, FNA = FILE_NAME, FNS = .FILE_SIZE, FOP = (MXV, CBT, SQO, TEF), NAM = FILE_NAM, ORG = SEQ, RFM = VAR); END; [FILE_FIX] : BEGIN $FAB_INIT (FAB = FILE_FAB, FAC = PUT, FNA = FILE_NAME, FNS = .FILE_SIZE, FOP = (MXV, CBT, SQO, TEF), NAM = FILE_NAM, ORG = SEQ, RFM = FIX, MRS = (IF .file_blocksize_set THEN .file_blocksize ELSE 512)); END; [FILE_BLK] : BEGIN $FAB_INIT (FAB = FILE_FAB, FAC = (PUT, BIO), FNA = FILE_NAME, FNS = .FILE_SIZE, FOP = (MXV, CBT, SQO, TEF), NAM = FILE_NAM); END; TES; ! ! If we had an alternate file name from the receive command, use it ! instead of what KERMSG has told us. ! IF .ALT_FILE_SIZE GTR 0 THEN BEGIN LOCAL ALT_FILE_DESC : BLOCK [8, BYTE]; ALT_FILE_DESC = .FILE_DESC; ALT_FILE_DESC [DSC$W_LENGTH] = .ALT_FILE_SIZE; ALT_FILE_DESC [DSC$A_POINTER] = ALT_FILE_NAME; IF USER_FILE_CHECK NEQ 0 THEN BEGIN STATUS = USER_FILE_CHECK (ALT_FILE_DESC, %REF (.FILE_MODE EQL FNC_READ)); IF NOT .STATUS THEN BEGIN LIB$SIGNAL (.STATUS); RETURN .STATUS; END; END; FILE_FAB [FAB$L_FNA] = ALT_FILE_NAME; FILE_FAB [FAB$B_FNS] = .ALT_FILE_SIZE; END; $NAM_INIT (NAM = FILE_NAM, ESA = EXP_STR, ESS = NAM$C_MAXRSS, RSA = RES_STR, RSS = NAM$C_MAXRSS); ! ! Now allocate a buffer for the records ! ! Determine correct buffer size SELECTONE .FILE_TYPE OF SET [FILE_ASC] : REC_SIZE = MAX_REC_LENGTH; [FILE_BIN] : REC_SIZE = (IF .file_blocksize_set THEN .file_blocksize ELSE 510); [FILE_BLK] : REC_SIZE = 512; [FILE_FIX] : REC_SIZE = (IF .file_blocksize_set THEN .file_blocksize ELSE 512); TES; STATUS = LIB$GET_VM (REC_SIZE, REC_ADDRESS); ! ! Now create the file ! STATUS = $CREATE (FAB = FILE_FAB); IF NOT .STATUS THEN BEGIN FILE_ERROR (.STATUS); RETURN KER_RMS32; END; $RAB_INIT (RAB = FILE_RAB, FAB = FILE_FAB, RAC = SEQ, RBF = .REC_ADDRESS, ROP = ); STATUS = $CONNECT (RAB = FILE_RAB); IF NOT .STATUS THEN BEGIN FILE_ERROR (.STATUS); RETURN KER_RMS32; END; ! ! Set the initial state into the FAB field. This is used to remember ! whether we need to ignore the line feed which follows a carriage return. ! FILE_FAB [FAB$L_CTX] = F_STATE_DATA; FILE_REC_COUNT = 0; FILE_REC_POINTER = CH$PTR (.REC_ADDRESS); ! ! Tell user what name we ended up with for storing the file ! IF ( NOT .CONNECT_FLAG) AND .TY_FIL THEN BEGIN TT_TEXT (UPLIT (%ASCIZ' as ')); IF .FILE_NAM [NAM$B_RSL] GTR 0 THEN BEGIN CH$WCHAR (CHR_NUL, CH$PTR (.FILE_NAM [NAM$L_RSA], .FILE_NAM [NAM$B_RSL])); TT_TEXT (.FILE_NAM [NAM$L_RSA]); END ELSE BEGIN CH$WCHAR (CHR_NUL, CH$PTR (.FILE_NAM [NAM$L_ESA], .FILE_NAM [NAM$B_ESL])); TT_TEXT (.FILE_NAM [NAM$L_ESA]); END; TT_OUTPUT (); END; END; [OTHERWISE] : RETURN KER_INTERNALERR; TES; ! ! Copy the file name based on the type of file name we are to use. ! The possibilities are: ! Normal - Just copy name and type ! Full - Copy entire name string (either resultant or expanded) ! Untranslated - Copy string from name on (includes version, etc.) IF .DEV_CLASS EQL DC$_MAILBOX THEN BEGIN SIZE = 0; FILE_NAME = 0; END ELSE SELECTONE .FIL_NORMAL_FORM OF SET [FNM_FULL] : BEGIN IF .FILE_NAM [NAM$B_RSL] GTR 0 THEN BEGIN CH$COPY (.FILE_NAM [NAM$B_RSL], CH$PTR (.FILE_NAM [NAM$L_RSA]), CHR_NUL, MAX_FILE_NAME, CH$PTR (FILE_NAME)); SIZE = .FILE_NAM [NAM$B_RSL]; END ELSE BEGIN CH$COPY (.FILE_NAM [NAM$B_ESL], CH$PTR (.FILE_NAM [NAM$L_ESA]), CHR_NUL, MAX_FILE_NAME, CH$PTR (FILE_NAME)); SIZE = .FILE_NAM [NAM$B_ESL]; END END; [FNM_NORMAL, FNM_UNTRAN] : BEGIN CH$COPY (.FILE_NAM [NAM$B_NAME], CH$PTR (.FILE_NAM [NAM$L_NAME]), .FILE_NAM [NAM$B_TYPE], CH$PTR (.FILE_NAM [NAM$L_TYPE]), CHR_NUL, MAX_FILE_NAME, CH$PTR (FILE_NAME)); SIZE = .FILE_NAM [NAM$B_NAME] + .FILE_NAM [NAM$B_TYPE]; END; TES; IF .SIZE GTR MAX_FILE_NAME THEN FILE_SIZE = MAX_FILE_NAME ELSE FILE_SIZE = .SIZE; RETURN KER_NORMAL; END; ! End of FILE_OPEN %SBTTL 'FILE_CLOSE' GLOBAL ROUTINE FILE_CLOSE (ABORT_FLAG) = !++ ! FUNCTIONAL DESCRIPTION: ! ! This routine will close a file that was opened by FILE_OPEN. ! It assumes any data associated with the file is stored in this ! module, since this routine is called by KERMSG. ! ! CALLING SEQUENCE: ! ! FILE_CLOSE(); ! ! INPUT PARAMETERS: ! ! ABORT_FLAG - True if file should not be saved. ! ! IMPLICIT INPUTS: ! ! None. ! ! OUTPUT PARAMETERS: ! ! None. ! ! IMPLICIT OUTPUTS: ! ! None. ! ! COMPLETION CODES: ! ! None. ! ! SIDE EFFECTS: ! ! None. ! !-- BEGIN ! ! Completion codes returned: ! EXTERNAL LITERAL KER_NORMAL, ! Normal return KER_RMS32; ! RMS-32 error LOCAL STATUS; ! Random status values ! ! If there might be something left to write ! IF .FILE_MODE EQL FNC_WRITE AND (.FILE_REC_COUNT GTR 0 OR .FILE_FAB [FAB$L_CTX] NEQ F_STATE_DATA) THEN BEGIN SELECTONE .FILE_TYPE OF SET [FILE_FIX] : BEGIN INCR I FROM .FILE_REC_COUNT TO .REC_SIZE - 1 DO CH$WCHAR_A (CHR_NUL, FILE_REC_POINTER); FILE_REC_COUNT = .REC_SIZE; ! Store the byte count STATUS = DUMP_BUFFER (); END; [FILE_ASC, FILE_BIN] : STATUS = DUMP_BUFFER (); [FILE_BLK] : BEGIN FILE_RAB [RAB$W_RSZ] = .FILE_REC_COUNT; STATUS = $WRITE (RAB = FILE_RAB); IF NOT .STATUS THEN BEGIN FILE_ERROR (.STATUS); STATUS = KER_RMS32; END ELSE STATUS = KER_NORMAL; END; TES; IF NOT .STATUS THEN RETURN .STATUS; END; ! ! If reading from a mailbox, read until EOF to allow the process on the other ! end to terminal gracefully. ! IF .FILE_MODE EQL FNC_READ AND .DEV_CLASS EQL DC$_MAILBOX AND NOT .EOF_FLAG THEN DO STATUS = GET_BUFFER () UNTIL ( NOT .STATUS) OR .EOF_FLAG; STATUS = LIB$FREE_VM (REC_SIZE, REC_ADDRESS); IF .FIX_SIZE NEQ 0 THEN STATUS = LIB$FREE_VM (FIX_SIZE, FIX_ADDRESS); IF .ABORT_FLAG AND .FILE_MODE EQL FNC_WRITE THEN FILE_FAB [FAB$V_DLT] = TRUE ELSE FILE_FAB [FAB$V_DLT] = FALSE; STATUS = $CLOSE (FAB = FILE_FAB); EOF_FLAG = FALSE; IF NOT .STATUS THEN BEGIN FILE_ERROR (.STATUS); RETURN KER_RMS32; END ELSE RETURN KER_NORMAL; END; ! End of FILE_CLOSE %SBTTL 'NEXT_FILE' GLOBAL ROUTINE NEXT_FILE = !++ ! FUNCTIONAL DESCRIPTION: ! ! This routine will cause the next file to be opened. It will ! call the RMS-32 routine $SEARCH and $OPEN for the file. ! ! CALLING SEQUENCE: ! ! STATUS = NEXT_FILE; ! ! INPUT PARAMETERS: ! ! None. ! ! IMPLICIT INPUTS: ! ! FAB/NAM blocks set up from previous processing. ! ! OUTPUT PARAMETERS: ! ! None. ! ! IMPLICIT OUTPUTS: ! ! FAB/NAM blocks set up for the next file. ! ! COMPLETION CODES: ! ! TRUE - There is a next file. ! KER_RMS32 - No next file. ! ! SIDE EFFECTS: ! ! None. ! !-- BEGIN ! ! Completion codes returned: ! EXTERNAL LITERAL KER_NORMAL, ! Normal return KER_NOMORFILES, ! No more files to read KER_RMS32; ! RMS-32 error EXTERNAL ROUTINE TT_TEXT : NOVALUE; ! Output an ASCIZ string LOCAL SIZE : WORD, ! Size of the $FAO string STATUS; ! Random status values ! ! If we can't do a search, just return no more files ! IF NOT .SEARCH_FLAG THEN RETURN KER_NOMORFILES; ! ! Now search for the next file that we want to process. ! STATUS = $SEARCH (FAB = FILE_FAB); IF .STATUS EQL RMS$_NMF THEN RETURN KER_NOMORFILES; IF NOT .STATUS THEN BEGIN FILE_ERROR (.STATUS); RETURN KER_RMS32; END; ! ! Now we have the new file name. All that we have to do is open the file ! for reading now. ! STATUS = OPEN_READING (); IF NOT .STATUS THEN RETURN .STATUS; ! ! Copy the file name based on the type of file name we are to use. ! The possibilities are: ! Normal - Just copy name and type ! Full - Copy entire name string (either resultant or expanded) ! Untranslated - Copy string from name on (includes version, etc.) SELECTONE .FIL_NORMAL_FORM OF SET [FNM_FULL] : BEGIN IF .FILE_NAM [NAM$B_RSL] GTR 0 THEN BEGIN CH$COPY (.FILE_NAM [NAM$B_RSL], CH$PTR (.FILE_NAM [NAM$L_RSA]), CHR_NUL, MAX_FILE_NAME, CH$PTR (FILE_NAME)); SIZE = .FILE_NAM [NAM$B_RSL]; END ELSE BEGIN CH$COPY (.FILE_NAM [NAM$B_ESL], CH$PTR (.FILE_NAM [NAM$L_ESA]), CHR_NUL, MAX_FILE_NAME, CH$PTR (FILE_NAME)); SIZE = .FILE_NAM [NAM$B_ESL]; END END; [FNM_NORMAL, FNM_UNTRAN] : BEGIN CH$COPY (.FILE_NAM [NAM$B_NAME], CH$PTR (.FILE_NAM [NAM$L_NAME]), .FILE_NAM [NAM$B_TYPE], CH$PTR (.FILE_NAM [NAM$L_TYPE]), CHR_NUL, MAX_FILE_NAME, CH$PTR (FILE_NAME)); SIZE = .FILE_NAM [NAM$B_NAME] + .FILE_NAM [NAM$B_TYPE]; END; TES; IF .SIZE GTR MAX_FILE_NAME THEN FILE_SIZE = MAX_FILE_NAME ELSE FILE_SIZE = .SIZE; ! ! Put prompt for NEXT_FILE sending in here ! IF ( NOT .CONNECT_FLAG) AND .TY_FIL THEN BEGIN TT_TEXT (UPLIT (%ASCIZ 'Sending: ')); .FILE_NAM [NAM$L_RSA] + .FILE_NAM [NAM$B_RSL] = 0; TT_TEXT (.FILE_NAM [NAM$L_RSA]); TT_TEXT (UPLIT (%ASCIZ ' as ')); TT_OUTPUT (); END; RETURN KER_NORMAL; END; ! End of NEXT_FILE %SBTTL 'LOG_OPEN - Open a log file' GLOBAL ROUTINE LOG_OPEN (LOG_DESC, LOG_FAB, LOG_RAB) = !++ ! FUNCTIONAL DESCRIPTION: ! ! CALLING SEQUENCE: ! ! STATUS = LOG_OPEN (LOG_DESC, LOG_FAB, LOG_RAB) ! ! INPUT PARAMETERS: ! ! LOG_DESC - Address of descriptor for file name to be opened ! ! LOG_FAB - Address of FAB for file ! ! LOG_RAB - Address of RAB for file ! ! IMPLICIT INPUTS: ! ! None. ! ! OUPTUT PARAMETERS: ! ! LOG_FAB and LOG_RAB updated. ! ! IMPLICIT OUTPUTS: ! ! None. ! ! COMPLETION CODES: ! ! Error code or true. ! ! SIDE EFFECTS: ! ! None. ! !-- BEGIN ! ! Completion codes returned: ! EXTERNAL LITERAL KER_NORMAL, ! Normal return KER_RMS32; ! RMS-32 error MAP LOG_DESC : REF BLOCK [8, BYTE], ! Name descriptor LOG_FAB : REF $FAB_DECL, ! FAB for file LOG_RAB : REF $RAB_DECL; ! RAB for file LOCAL STATUS, ! Random status values REC_ADDRESS, ! Address of record buffer REC_SIZE; ! Size of record buffer ! ! Get memory for records ! REC_SIZE = LOG_BUFF_SIZE; STATUS = LIB$GET_VM (REC_SIZE, REC_ADDRESS); IF NOT .STATUS THEN BEGIN LIB$SIGNAL (.STATUS); RETURN .STATUS; END; ! ! Initialize the FAB and RAB ! $FAB_INIT (FAB = .LOG_FAB, FAC = PUT, FNA = .LOG_DESC [DSC$A_POINTER], FNS = .LOG_DESC [DSC$W_LENGTH], FOP = (MXV, CBT, SQO, TEF), ORG = SEQ, RFM = VAR, RAT = CR, CTX = 0, DNA = UPLIT (%ASCII'.LOG'), DNS = 4); STATUS = $CREATE (FAB = .LOG_FAB); IF NOT .STATUS THEN BEGIN FILE_ERROR (.STATUS); LIB$FREE_VM (REC_SIZE, REC_ADDRESS); ! Dump record buffer RETURN KER_RMS32; END; $RAB_INIT (RAB = .LOG_RAB, FAB = .LOG_FAB, RAC = SEQ, RBF = .REC_ADDRESS, RSZ = .REC_SIZE, UBF = .REC_ADDRESS, USZ = .REC_SIZE, ROP = , CTX = 0); STATUS = $CONNECT (RAB = .LOG_RAB); IF NOT .STATUS THEN BEGIN FILE_ERROR (.STATUS); LIB$FREE_VM (REC_SIZE, REC_ADDRESS); $CLOSE (FAB = .LOG_FAB); RETURN KER_RMS32; END ELSE RETURN .STATUS; END; ! End of LOG_OPEN %SBTTL 'LOG_CLOSE - Close a log file' GLOBAL ROUTINE LOG_CLOSE (LOG_FAB, LOG_RAB) = !++ ! FUNCTIONAL DESCRIPTION: ! ! This routine will close an open log file. It will also ensure that !the last buffer gets dumped. ! ! CALLING SEQUENCE: ! ! STATUS = LOG_CLOSE (LOG_FAB, LOG_RAB); ! ! INPUT PARAMETERS: ! ! LOG_FAB - Address of log file FAB ! ! LOG_RAB - Address of log file RAB ! ! IMPLICIT INPUTS: ! ! None. ! ! OUPTUT PARAMETERS: ! ! None. ! ! IMPLICIT OUTPUTS: ! ! None. ! ! COMPLETION CODES: ! ! Resulting status. ! ! SIDE EFFECTS: ! ! None. ! !-- BEGIN ! ! Completion codes returned: ! EXTERNAL LITERAL KER_RMS32; ! RMS-32 error MAP LOG_FAB : REF $FAB_DECL, ! FAB for log file LOG_RAB : REF $RAB_DECL; ! RAB for log file LOCAL STATUS, ! Random status values REC_ADDRESS, ! Address of record buffer REC_SIZE; ! Size of record buffer ! ! First write out any outstanding data ! IF .LOG_RAB [RAB$L_CTX] GTR 0 THEN LOG_PUT (.LOG_RAB); ! Dump current buffer ! ! Return the buffer ! REC_SIZE = LOG_BUFF_SIZE; ! Get size of buffer REC_ADDRESS = .LOG_RAB [RAB$L_RBF]; ! And address LIB$FREE_VM (REC_SIZE, REC_ADDRESS); ! ! Now disconnect the RAB ! STATUS = $DISCONNECT (RAB = .LOG_RAB); IF NOT .STATUS THEN BEGIN FILE_ERROR (.STATUS); RETURN KER_RMS32; END; ! ! Now we can close the file ! STATUS = $CLOSE (FAB = .LOG_FAB); IF NOT .STATUS THEN FILE_ERROR (.STATUS); ! ! And return the result ! RETURN .STATUS; END; ! End of LOG_CLOSE %SBTTL 'LOG_CHAR - Log a character to a file' GLOBAL ROUTINE LOG_CHAR (CH, LOG_RAB) = !++ ! FUNCTIONAL DESCRIPTION: ! ! This routine will write one character to an open log file. !If the buffer becomes filled, it will dump it. It will also !dump the buffer if a carriage return line feed is seen. ! ! CALLING SEQUENCE: ! ! STATUS = LOG_CHAR (.CH, LOG_RAB); ! ! INPUT PARAMETERS: ! ! CH - The character to write to the file. ! ! LOG_RAB - The address of the log file RAB. ! ! IMPLICIT INPUTS: ! ! None. ! ! OUPTUT PARAMETERS: ! ! None. ! ! IMPLICIT OUTPUTS: ! ! None. ! ! COMPLETION CODES: ! ! Any error returned by LOG_PUT, else TRUE. ! ! SIDE EFFECTS: ! ! None. ! !-- BEGIN ! ! Completion codes returned: ! EXTERNAL LITERAL KER_NORMAL; ! Normal return MAP LOG_RAB : REF $RAB_DECL; ! Log file RAB LOCAL STATUS; ! Random status value ! ! If this character is a line feed, and previous was a carriage return, then ! dump the buffer and return. ! IF .CH EQL CHR_LFD THEN BEGIN ! ! If we seem to have overfilled the buffer, that is because we saw a CR ! last, and had no place to put it. Just reset the size and dump the buffer. ! IF .LOG_RAB [RAB$L_CTX] GTR LOG_BUFF_SIZE THEN BEGIN LOG_RAB [RAB$L_CTX] = LOG_BUFF_SIZE; RETURN LOG_PUT (.LOG_RAB); END; ! ! If last character in buffer is a CR, then dump buffer without the CR ! IF CH$RCHAR (CH$PTR (.LOG_RAB [RAB$L_RBF], .LOG_RAB [RAB$L_CTX] - 1)) EQL CHR_CRT THEN BEGIN LOG_RAB [RAB$L_CTX] = .LOG_RAB [RAB$L_CTX] - 1; RETURN LOG_PUT (.LOG_RAB); END; END; ! ! Don't need to dump buffer because of end of line problems. Check if ! the buffer is full. ! IF .LOG_RAB [RAB$L_CTX] GEQ LOG_BUFF_SIZE THEN BEGIN ! ! If character we want to store is a carriage return, then just count it and ! don't dump the buffer yet. ! IF .CH EQL CHR_CRT THEN BEGIN LOG_RAB [RAB$L_CTX] = .LOG_RAB [RAB$L_CTX] + 1; RETURN KER_NORMAL; END; ! ! We must dump the buffer to make room for more characters ! STATUS = LOG_PUT (.LOG_RAB); IF NOT .STATUS THEN RETURN .STATUS; END; ! ! Here when we have some room to store the character ! CH$WCHAR (.CH, CH$PTR (.LOG_RAB [RAB$L_RBF], .LOG_RAB [RAB$L_CTX])); LOG_RAB [RAB$L_CTX] = .LOG_RAB [RAB$L_CTX] + 1; RETURN KER_NORMAL; END; ! End of LOG_CHAR %SBTTL 'LOG_LINE - Log a line to a log file' GLOBAL ROUTINE LOG_LINE (LINE_DESC, LOG_RAB) = !++ ! FUNCTIONAL DESCRIPTION: ! ! This routine will write an entire line to a log file. And previously ! written characters will be dumped first. ! ! CALLING SEQUENCE: ! ! STATUS = LOG_LINE (LINE_DESC, LOG_RAB); ! ! INPUT PARAMETERS: ! ! LINE_DESC - Address of descriptor for string to be written ! ! LOG_RAB - RAB for log file ! ! IMPLICIT INPUTS: ! ! None. ! ! OUPTUT PARAMETERS: ! ! None. ! ! IMPLICIT OUTPUTS: ! ! None. ! ! COMPLETION CODES: ! ! KER_NORMAL or LOG_PUT error code. ! ! SIDE EFFECTS: ! ! None. ! !-- BEGIN MAP LINE_DESC : REF BLOCK [8, BYTE], ! Descriptor for string LOG_RAB : REF $RAB_DECL; ! RAB for file LOCAL STATUS; ! Random status value ! ! First check if anything is already in the buffer ! IF .LOG_RAB [RAB$L_CTX] GTR 0 THEN BEGIN STATUS = LOG_PUT (.LOG_RAB); ! Yes, write it out IF NOT .STATUS THEN RETURN .STATUS; ! Pass back any errors END; ! ! Copy the data to the buffer ! CH$COPY (.LINE_DESC [DSC$W_LENGTH], CH$PTR (.LINE_DESC [DSC$A_POINTER]), CHR_NUL, LOG_BUFF_SIZE, CH$PTR (.LOG_RAB [RAB$L_RBF])); IF .LINE_DESC [DSC$W_LENGTH] GTR LOG_BUFF_SIZE THEN LOG_RAB [RAB$L_CTX] = LOG_BUFF_SIZE ELSE LOG_RAB [RAB$L_CTX] = .LINE_DESC [DSC$W_LENGTH]; ! ! Now just dump the buffer ! RETURN LOG_PUT (.LOG_RAB); END; ! End of LOG_LINE %SBTTL 'LOG_FAOL - Log an FAO string to the log file' GLOBAL ROUTINE LOG_FAOL (FAOL_DESC, FAOL_PARAMS, LOG_RAB) = !++ ! FUNCTIONAL DESCRIPTION: ! ! This routine will write an FAOL string to the output file. ! ! CALLING SEQUENCE: ! ! STATUS = LOG_FAOL (FAOL_DESC, FAOL_PARAMS, LOG_RAB); ! ! INPUT PARAMETERS: ! ! FAOL_DESC - Address of descriptor for string to be written ! ! FAOL_PARAMS - Parameter list for FAOL call ! ! LOG_RAB - RAB for log file ! ! IMPLICIT INPUTS: ! ! None. ! ! OUPTUT PARAMETERS: ! ! None. ! ! IMPLICIT OUTPUTS: ! ! None. ! ! COMPLETION CODES: ! ! KER_NORMAL or $FAOL or LOG_PUT error code. ! ! SIDE EFFECTS: ! ! None. ! !-- BEGIN ! ! Completion codes returned: ! EXTERNAL LITERAL KER_NORMAL; ! Normal return MAP FAOL_DESC : REF BLOCK [8, BYTE], ! Descriptor for string LOG_RAB : REF $RAB_DECL; ! RAB for file LITERAL FAOL_BUFSIZ = 256; ! Length of buffer LOCAL FAOL_BUFFER : VECTOR [FAOL_BUFSIZ, BYTE], ! Buffer for FAOL output FAOL_BUF_DESC : BLOCK [8, BYTE], ! Descriptor for buffer STATUS; ! Random status value ! ! Initialize descriptor for buffer ! FAOL_BUF_DESC [DSC$B_CLASS] = DSC$K_CLASS_S; FAOL_BUF_DESC [DSC$B_DTYPE] = DSC$K_DTYPE_T; FAOL_BUF_DESC [DSC$A_POINTER] = FAOL_BUFFER; FAOL_BUF_DESC [DSC$W_LENGTH] = FAOL_BUFSIZ; ! ! Now do the FAOL to generate the full text ! STATUS = $FAOL (CTRSTR = .FAOL_DESC, OUTBUF = FAOL_BUF_DESC, OUTLEN = FAOL_BUF_DESC [DSC$W_LENGTH], PRMLST = .FAOL_PARAMS); IF NOT .STATUS THEN RETURN .STATUS; ! ! Dump the text into the file ! INCR I FROM 1 TO .FAOL_BUF_DESC [DSC$W_LENGTH] DO BEGIN STATUS = LOG_CHAR ( .FAOL_BUFFER [.I - 1], .LOG_RAB); IF NOT .STATUS THEN RETURN .STATUS; END; RETURN KER_NORMAL; END; ! End of LOG_FAOL %SBTTL 'LOG_PUT - Write a record buffer for a log file' ROUTINE LOG_PUT (LOG_RAB) = !++ ! FUNCTIONAL DESCRIPTION: ! ! This routine will output one buffer for a log file. ! ! CALLING SEQUENCE: ! ! STATUS = LOG_PUT (LOG_RAB); ! ! INPUT PARAMETERS: ! ! LOG_RAB - RAB for log file. ! ! IMPLICIT INPUTS: ! ! None. ! ! OUPTUT PARAMETERS: ! ! None. ! ! IMPLICIT OUTPUTS: ! ! None. ! ! COMPLETION CODES: ! ! Status value from RMS ! ! SIDE EFFECTS: ! ! None. ! !-- BEGIN MAP LOG_RAB : REF $RAB_DECL; ! RAB for file ! ! Calculate record size ! LOG_RAB [RAB$W_RSZ] = .LOG_RAB [RAB$L_CTX]; LOG_RAB [RAB$W_USZ] = .LOG_RAB [RAB$W_RSZ]; ! ! Buffer will be empty when we finish ! LOG_RAB [RAB$L_CTX] = 0; ! ! And call RMS to write the buffer ! RETURN $PUT (RAB = .LOG_RAB); END; ! End of LOG_PUT %SBTTL 'FILE_ERROR - Error processing for all RMS errors' ROUTINE FILE_ERROR (STATUS) : NOVALUE = !++ ! FUNCTIONAL DESCRIPTION: ! ! This routine will process all of the RMS-32 error returns. It will ! get the text for the error and then it will issue a KER_ERROR for ! the RMS failure. ! ! CALLING SEQUENCE: ! ! FILE_ERROR(); ! ! INPUT PARAMETERS: ! ! None. ! ! IMPLICIT INPUTS: ! ! STATUS - RMS error status. ! FILE_NAME - File name and extension. ! FILE_SIZE - Size of the thing in FILE_NAME. ! ! OUTPUT PARAMETERS: ! ! None. ! ! IMPLICIT OUTPUTS: ! ! None. ! ! COMPLETION CODES: ! ! None. ! ! SIDE EFFECTS: ! ! None. ! !-- BEGIN ! ! KERMIT completion codes ! EXTERNAL LITERAL KER_RMS32; ! RMS-32 error LOCAL ERR_BUFFER : VECTOR [CH$ALLOCATION (MAX_MSG)], ERR_DESC : BLOCK [8, BYTE] PRESET ! String descriptor to ([DSC$B_CLASS ] = DSC$K_CLASS_S, ! the error buffer [DSC$B_DTYPE ] = DSC$K_DTYPE_T, ! standard string [DSC$W_LENGTH ] = MAX_MSG, ! descriptor [DSC$A_POINTER ] = ERR_BUFFER); $GETMSG (MSGID = .STATUS, MSGLEN = ERR_DESC [DSC$W_LENGTH], BUFADR = ERR_DESC, FLAGS = 1); LIB$SIGNAL (KER_RMS32, 2, ERR_DESC, FILE_DESC); END; ! End of FILE_ERROR %SBTTL 'End of KERFIL' END ! End of module ELUDOM