MGFTP023.Gt2 MGFTP023.GBACKUP/INTERCHANGE/BLOCK=8192 FTP_SRC_FILES.TXT;,[-.SOURCE]*.B32;,*.R32;,*.MMS;,*.MSG;,*.CLD;,*.MAR;,*.OPT; MG_KIT:[MGFTP]MGFTP023.G/SAVE GOATHUNTER c*V7.1 _GHUNT1:: _$1$DKA100: V6.2  *[MGFTP.KIT]FTP_SRC_FILES.TXT;3+,%b ./ 4;f-~J0123KPWO 56OX7s e89\A#GHJ!MadGoat FTP Source files!!BLISS modules4FTP_TMP ACTIVITY_LOG.B32 MADGOAT_ROOT:[SOURCES.FTP]-FTP_TMP ANON.B32 MADGOAT_ROOT:[SOURCES.FTP]2FTP_TMP CMD_PARSE.B32 MADGOAT_ROOT:[SOURCES.FTP]2FTP_TMP CONDITION.B32 MADGOAT_ROOT:[SOURCES.FTP]2FTP_TMP CONTROL_C.B32 MADGOAT_ROOT:[SOURCES.FTP];FTP_TMP COPY_DIR_FTP_SUPPORT.B32 MADGOAT_ROOT:[SOURCES.FTP]-FTP_TMP DIR.B32 MADGOAT_ROOT:[SOURCES.FTP]2FTP_TMP FILE_INFO.B32 MADGOAT_ROOT:[SOURCES.FTP]-FTP_TMP FTP.B32 MADGOAT_ROOT:[SOURCES.FTP]2FTP_TMP FTP_ALIAS.B32 MADGOAT_ROOT:[SOURCES.FTP]6FTP_TMP FTP_ALIAS_CMDS.B32 MADGOAT_ROOT:[SOURCES.FTP]4FTP_TMP FTP_ANNOUNCE.B32 MADGOAT_ROOT:[SOURCES.FTP]1FTP_TMP FTP_DTON.B32 MADGOAT_ROOT:[SOURCES.FTP]1FTP_TMP FTP_DTOT.B32 MADGOAT_ROOT:[SOURCES.FTP]1FTP_TMP FTP_FILE.B32 MADGOAT_ROOT:[SOURCES.FTP]1FTP_TMP FTP_FTON.B32 MADGOAT_ROOT:[SOURCES.FTP]4FTP_TMP FTP_HANDLER.B32 MADGOAT_ROOT:[SOURCES.FTP]1FTP_TMP FTP_HELP.B32 MADGOAT_ROOT:[SOURCES.FTP]/FTP_TMP FTP_IN.B32 MADGOAT_ROOT:[SOURCES.FTP]2FTP_TMP FTP_INPUT.B32 MADGOAT_ROOT:[SOURCES.FTP]4FTP_TMP FTP_LISTENER.B32 MADGOAT_ROOT:[SOURCES.FTP]9FTP_TMP FTP_LISTENER_CMDS.B32 MADGOAT_ROOT:[SOURCES.FTP]8FTP_TMP FTP_LISTENER_MEM.B32 MADGOAT_ROOT:[SOURCES.FTP]4FTP_TMP FTP_NETWORK.B32 MADGOAT_ROOT:[SOURCES.FTP]1FTP_TMP FTP_NTOF.B32 MADGOAT_ROOT:[SOURCES.FTP]1FTP_TMP FTP_NTOT.B32 MADGOAT_ROOT:[SOURCES.FTP]2FTP_TMP FTP_QUEUE.B32 MADGOAT_ROOT:[SOURCES.FTP]3FTP_TMP FTP_SERVER.B32 MADGOAT_ROOT:[SOURCES.FTP]7FTP_TMP FTP_SERVER_CMDS.B32 MADGOAT_ROOT:[SOURCES.FTP]6FTP_TMP FTP_SET_PARAMS.B32 MADGOAT_ROOT:[SOURCES.FTP]-FTP_TMP HASH.B32 MADGOAT_ROOT:[SOURCES.FTP].FTP_TMP LOGIN.B32 MADGOAT_ROOT:[SOURCES.FTP]7FTP_TMP LOG_TO_LISTENER.B32 MADGOAT_ROOT:[SOURCES.FTP]-FTP_TMP MEM.B32 MADGOAT_ROOT:[SOURCES.FTP]/FTP_TMP NETLIB.B32 MADGOAT_ROOT:[SOURCES.FTP]3FTP_TMP PARSE_MODE.B32 MADGOAT_ROOT:[SOURCES.FTP]3FTP_TMP PARSE_PASV.B32 MADGOAT_ROOT:[SOURCES.FTP]3FTP_TMP PARSE_PORT.B32 MADGOAT_ROOT:[SOURCES.FTP]3FTP_TMP PARSE_STRU.B32 MADGOAT_ROOT:[SOURCES.FTP]3FTP_TMP PARSE_TYPE.B32 MADGOAT_ROOT:[SOURCES.FTP]-FTP_TMP PORT.B32 MADGOAT_ROOT:[SOURCES.FTP]1FTP_TMP ROUTINES.B32 MADGOAT_ROOT:[SOURCES.FTP]/FTP_TMP STRING.B32 MADGOAT_ROOT:[SOURCES.FTP]-FTP_TMP TEXT.B32 MADGOAT_ROOT:[SOURCES.FTP]/FTP_TMP VMS054.B32 MADGOAT_ROOT:[SOURCES.FTP]!!BLISS library files!1FTP_TMP ANON_FTP.R32 MADGOAT_ROOT:[SOURCES.FTP]-FTP_TMP CLI.R32 MADGOAT_ROOT:[SOURCES.FTP]/FTP_TMP FIELDS.R32 MADGOAT_ROOT:[SOURCES.FTP]-FTP_TMP FTP.R32 MADGOAT_ROOT:[SOURCES.FTP]/FTP_TMP FTPSRV.R32 MADGOAT_ROOT:[SOURCES.FTP]2FTP_TMP FTP_ALIAS.R32 MADGOAT_ROOT:[SOURCES.FTP]5FTP_TMP FTP_CONN_INFO.R32 MADGOAT_ROOT:[SOURCES.FTP]/FTP_TMP FTP_IN.R32 MADGOAT_ROOT:[SOURCES.FTP]4FTP_TMP FTP_LISTENER.R32 MADGOAT_ROOT:[SOURCES.FTP]0FTP_TMP FTP_MSG.R32 MADGOAT_ROOT:[SOURCES.FTP]/FTP_TMP NETAUX.R32 MADGOAT_ROOT:[SOURCES.FTP]/FTP_TMP NETLIB.R32 MADGOAT_ROOT:[SOURCES.FTP]-FTP_TMP TEXT.R32 MADGOAT_ROOT:[SOURCES.FTP]-FTP_TMP TPA.R32 MADGOAT_ROOT:[SOURCES.FTP]0FTP_TMP VERSION.R32 MADGOAT_ROOT:[SOURCES.FTP]!! MMS/MMK file!0FTP_TMP DESCRIP.MMS MADGOAT_ROOT:[SOURCES.FTP]!! Message files!/FTP_TMP FTPSRV.MSG MADGOAT_ROOT:[SOURCES.FTP]0FTP_TMP FTP_MSG.MSG MADGOAT_ROOT:[SOURCES.FTP]!! Command definition utilities!0FTP_TMP FTP_CMD.CLD MADGOAT_ROOT:[SOURCES.FTP]4FTP_TMP FTP_NOREPLY.CLD MADGOAT_ROOT:[SOURCES.FTP]2FTP_TMP FTP_PARSE.CLD MADGOAT_ROOT:[SOURCES.FTP]9FTP_TMP FTP_PARSE_NO_HOST.CLD MADGOAT_ROOT:[SOURCES.FTP]2FTP_TMP FTP_QUIET.CLD MADGOAT_ROOT:[SOURCES.FTP]8FTP_TMP FTP_SERVER_PARSE.CLD MADGOAT_ROOT:[SOURCES.FTP]!! Miscellaneous!-FTP_TMP HPWD.MAR MADGOAT_ROOT:[SOURCES.FTP]/FTP_TMP NETLIB.OPT MADGOAT_ROOT:[SOURCES.FTP]2FTP_TMP NETLIBDEF.R32 MADGOAT_ROOT:[SOURCES.FTP]   MGFTP023.GII [MGFTP.SOURCE]ACTIVITY_LOG.B32;1C~ *[MGFTP.SOURCE]ACTIVITY_LOG.B32;1+,I./ 4Ct-I0123KPWO56:yM|!ӗ7쿦89\A#GHJ  ! MadGoat FTP client and server!?! Authors: Chad Wilson, Dale Moore, Tod Shannon, Bruce Miller,,! Marc Shannon, Henry Miller, John Clement,1! Matt Madison, Darrell Burkhead, Hunter Goatley!6! Copyright 1986, 1992, Carnegie Mellon University.<! Copyright 1994, MadGoat Software. All rights reserved.!?! Permission is granted for not-for-profit redistribution,?! provided all source and object code remain unchanged from?! the original distribution, and that all copyright notices! remain intact.!MODULE ACTIVITY_LOG( ADDRESSING_MODE( EXTERNAL = LONG_RELATIVE, NONEXTERNAL = LONG_RELATIVE), IDENT = 'V2.0',& LIST(ASSEMBLY, NOBINARY, NOEXPAND)) =BEGIN!++! ACTIVITY_LOG.B32!! Description:!C! This module contains routines to take the place of CMU's activity! logging for UCX.!.! Written By: Darrell Burkhead 16-APR-1993 WKU!! Modifications:!!--LIBRARY 'SYS$LIBRARY:STARLET';OWN. act_fab : $FAB( FNM = 'MADGOAT_FTP_ACTIVITY',# DNM = 'MADGOAT_ROOT:[LOGS].LOG', FAC = PUT, FOP = MXV, ORG = SEQ, RAT = CR, RFM = VAR, SHR = GET), act_rab : $RAB( FAB = act_fab, RAC = SEQ); %SBTTL 'CREATE_ACT_LOG'GLOBAL ROUTINE create_act_log=!++!! Routine: CREATE_ACT_LOG!! Description:!<! This routine creates the activity log for this FTP server.! ! Parameters:!! None.! ! Returns:!! RMS$_NORMAL, success!!--BEGINREGISTER status : UNSIGNED LONG;< status = $CREATE( FAB = act_fab ); !Create the log file' IF NOT .status THEN RETURN .status;: status = $CONNECT( RAB = act_rab ); !Connect a stream RETURN .status;END; %SBTTL 'WRITE_ACT_LOG')GLOBAL ROUTINE write_act_log(act_line_a)=!++!! Routine: WRITE_ACT_LOG!! Description:!1! This routine writes a line to the activity log.! ! Parameters:!C! act_line_a - address of a descriptor containing the line to write! ! Returns:!! RMS$_NORMAL, success!!--BEGINREGISTER status : UNSIGNED LONG;BIND" act_line = .act_line_a : $BBLOCK;1 act_rab[RAB$W_RSZ] = .act_line[DSC$W_LENGTH];2 act_rab[RAB$L_RBF] = .act_line[DSC$A_POINTER];4 status = $PUT( RAB = act_rab ); !Write the line IF .status* THEN status = $FLUSH( RAB = act_rab ); .statusEND;ENDELUDOM*[MGFTP.SOURCE]ANON.B32;22+,|B.4/ 4K42-I0123KPWO356 2_"n7T"n89\A#GHJ ! MadGoat FTP client and server!?! Authors: Chad Wilson, Dale Moore, Tod Shannon, Bruce Miller,,! Marc Shannon, Henry Miller, John Clement,1! Matt Madison, Darrell Burkhead, Hunter Goatley!6! Copyright 1986, 1992, Carnegie Mellon University.B! Copyright 1994, 1996, MadGoat Software. All rights reserved.!?! Permission is granted for not-for-profit redistribution,?! provided all source and object code remain unchanged from?! the original distribution, and that all copyright notices! remain intact.! %TITLE 'ANON'MODULE anon(IDENT = 'V2.2',J ADDRESSING_MODE(EXTERNAL=LONG_RELATIVE, NONEXTERNAL=LONG_RELATIVE)) =BEGIN!++! FACILITY: FTP! ! ABSTRACT:!C! This module provides routines for implementing ANONYMOUS FTP in! the FTP_SERVER.!! MODULE DESCRIPTION:!H! This module contains routines for logging ANONYMOUS FTP transactions6! and controlling ANONYMOUS's access to directories.!! AUTHOR: M. Madison!! CREATION DATE: 11-AUG-1988!! MODIFICATION HISTORY:!)! V2.2 Hunter Goatley 5-AUG-1996 23:06=! Added init_rdirq() and add_to_rdirq() to a) finish support8! for "~username" for anonymous connections and b) make7! these routines more efficient by not translating the/! logical names for every check_access() call.!,! V2.1-1 Darrell Burkhead 16-SEP-1994 11:06=! Leave one of the .'s on the end of the directory string if>! it ends in "..." This allows skip_000000_dirs to strip off<! the 000000 directory for something like ROOT:[000000...].!*! V2.1 Darrell Burkhead 12-JUL-1994 15:056! Added support for dev:[*...] directory names in the<! MADGOAT_FTP_DIRS and MADGOAT_FTP_user_DIRS logical names.!+! V2.0-1 Hunter Goatley 16-MAY-1994 16:03<! Fixed handling of anonymous ftp dirs logical so that it's1! not wiped out if the log file can't be opened.!)! V2.0 Hunter Goatley 27-SEP-1993 07:34<! Modified to use ARGPTR so it will work under AXP. Though;! not the most efficient method, it was the easiest to do.,! Added MADGOAT_ to FTP_ANON logical names.!-- COMPILETIME debug = 0;LIBRARY 'SYS$LIBRARY:STARLET';LIBRARY 'FTP';LIBRARY 'FIELDS'; %IF debug%THEN LIBRARY 'NETAUX';%FIC%IF debug %THEN %MESSAGE('DEBUG mode is enabled in ANON.B32!') %FI;EXTERNAL ROUTINE2 LIB$GET_VM : BLISS ADDRESSING_MODE(GENERAL),2 LIB$FREE_VM : BLISS ADDRESSING_MODE(GENERAL), text_init, text_append;FORWARD ROUTINE anon_log_open, anon_log_fao, init_rdirq, add_to_rdirq, check_access, check_directory, skip_000000_dirs;LITERAL bufsize = 256; _DEF(ABL) ABL_L_FABPTR = _LONG, ABL_L_RABPTR = _LONG,' ABL_Q_BUFDSC = _BYTES(DSC$C_S_BLN), _OVERLAY(ABL_Q_BUFDSC) ABL_W_BUFLEN = _WORD, ABL_B_DTYPE = _BYTE, ABL_B_CLASS = _BYTE, ABL_L_BUFPTR = _LONG, _ENDOVERLAY# ABL_T_BUFFER = _BYTES(bufsize),# ABL_T_FAB = _BYTES(FAB$C_BLN)," ABL_T_RAB = _BYTES(RAB$C_BLN) _ENDDEF(ABL); _DEF(TXT)!++! Description:!:! The text is implemented using the VAXes absolute queues.>! Absolute queues are very similar to doubly circularly linked?! lists. The desc in the record is a dynamic string descriptor! used to store the text.!-- TXT_L_FLINK = _LONG, TXT_L_BLINK = _LONG,% TXT_Q_DESC = _BYTES(DSC$C_S_BLN), _OVERLAY(TXT_Q_DESC) TXT_W_LENGTH = _WORD, TXT_B_DTYPE = _BYTE, TXT_B_CLASS = _BYTE, TXT_A_POINTER = _LONG _ENDOVERLAY! TXT_Q_DESC = _QUAD _ENDDEF(TXT);BIND@ ! LOG_DIR is also used in a literal string as DNM for a FAB.< madgoat_ftp_log_dir = %ASCID'MADGOAT_FTP_ANON_LOG_DIR';EXTERNAL. madgoat_ftp_name_table, !Defined in FTP_IN exec_mode, !... lnm$dcl_logical, !... madgoat_ftp_dirs; !...OWN2 anonymous_ftp_dirs_log : $BBLOCK[DSC$K_S_BLN]; %SBTTL 'ANON_LOG_OPEN';GLOBAL ROUTINE anon_log_open(ablock_a_a, anon_dir_log_a) = BEGIN!++! FUNCTIONAL DESCRIPTION:!?! This routine opens a log file for an ANONYMOUS FTP session.!A! RETURNS: cond_value, longword(unsigned), write only, by value! ! PROTOTYPE:!! anon_log_open!! IMPLICIT INPUTS: LOG_OPEN!&! IMPLICIT OUTPUTS: FAB, RAB, LOG_OPEN!! COMPLETION CODES:!2! SS$_NORMAL: normal successful completion.!! SIDE EFFECTS:! ! None.!-- EXTERNAL ROUTINE. STR$COPY_DX : BLISS ADDRESSING_MODE(GENERAL),/ STR$FREE1_DX : BLISS ADDRESSING_MODE(GENERA  MGFTP023.G|BI[MGFTP.SOURCE]ANON.B32;22K4 L),/ STR$FREE1_DX : BLISS ADDRESSING_MODE(GENERAL),1 LIB$SYS_TRNLOG : BLISS ADDRESSING_MODE(GENERAL); BIND* ablock_a = .ablock_a_a : REF ABLDEF,* anon_dir_log = .anon_dir_log_a : $BBLOCK; LOCAL log_dir: $BBLOCK [DSC$K_S_BLN], status; %IF debug! %THEN print('anon_log_open'); %FI !C ! Copy anonymous ftp directories logical name to OWN variable. !* $INIT_DYNDESC(anonymous_ftp_dirs_log);6 STR$COPY_DX(anonymous_ftp_dirs_log, anon_dir_log); ablock_a = 0;6 status = LIB$GET_VM(%REF(ABL_S_ABLDEF), ablock_a);' IF NOT .status THEN RETURN(.status) ELSE BEGIN BIND# ablk = .ablock_a : ABLDEF;- ablk[ABL_L_BUFPTR] = ablk[ABL_T_BUFFER];" ablk[ABL_W_BUFLEN] = bufsize;' ablk[ABL_B_DTYPE] = DSC$K_DTYPE_T;' ablk[ABL_B_CLASS] = DSC$K_CLASS_S; $INIT_DYNDESC(log_dir);: status = LIB$SYS_TRNLOG(madgoat_ftp_log_dir, 0, log_dir);' IF .status AND .status NEQU SS$_NOTRAN THEN $FAB_INIT( FAB = ablk[ABL_T_FAB], FNM = 'ANON_FTP_LOG',( DNM = 'MADGOAT_FTP_ANON_LOG_DIR:.LOG', FAC = PUT, SHR = SHRPUT, RFM = VAR, RAT = CR) ELSE $FAB_INIT( FAB = ablk[ABL_T_FAB], FNM = 'ANON_FTP_LOG', DNM = 'SYS$LOGIN:.LOG', FAC = PUT, SHR = SHRPUT, RFM = VAR, RAT = CR);- status = $CREATE(FAB = ablk[ABL_T_FAB]); IF .status THEN BEGIN $RAB_INIT( RAB = ablk[ABL_T_RAB], FAB = ablk[ABL_T_FAB], RBF = ablk[ABL_T_BUFFER]);. status = $CONNECT(RAB = ablk[ABL_T_RAB]); END; IF NOT .status THEN BEGIN %IF debug8 %THEN print('anon_log_open: status = !XL', .status); %FI' $CLOSE(FAB = ablk[ABL_T_FAB]);3 LIB$FREE_VM(%REF(abl_s_abldef), ablock_a); ablock_a = 0; RETURN(.status); END; END; SS$_NORMALEND; ! anon_log_open %SBTTL 'ANON_LOG_CLOSE'*GLOBAL ROUTINE anon_log_close(ablock_a) = BEGIN!++! FUNCTIONAL DESCRIPTION:!6! This routine closes the ANONYMOUS FTP session log.!A! RETURNS: cond_value, longword(unsigned), write only, by value! ! PROTOTYPE:!! ANON_LOG_CLOSE!!! IMPLICIT INPUTS: FAB, LOG_OPEN!!! IMPLICIT OUTPUTS: FAB, LOG_OPEN!! COMPLETION CODES:!2! SS$_NORMAL: normal successful completion.!! SIDE EFFECTS:! ! None.!-- BIND ablk = .ablock_a : ABLDEF; %IF debug" %THEN print('ANON_LOG_CLOSE'); %FI IF .ablock_a NEQ 0 THEN BEGIN# $CLOSE(fab = ablk[ABL_T_FAB]);/ LIB$FREE_VM(%REF(abl_s_abldef), ablock_a); END; SS$_NORMALEND; ! ANON_LOG_CLOSE %SBTTL 'ANON_LOG_FAO'(GLOBAL ROUTINE anon_log_fao(ablock_a) = BEGIN!++! FUNCTIONAL DESCRIPTION:!=! This routine formats a string using $FAO and writes it to! the ANONYMOUS FTP log.!A! RETURNS: cond_value, longword(unsigned), write only, by value! ! PROTOTYPE:!! anon_log_fao!)! IMPLICIT INPUTS: LOG_OPEN, RAB, LOGBUF!! IMPLICIT OUTPUTS: RAB, LOGBUF!! COMPLETION CODES:!2! SS$_NORMAL: normal successful completion.!! SIDE EFFECTS:! ! None.!-- BUILTIN ARGPTR; BIND' arglst = ARGPTR() : VECTOR[,LONG], ablk = .ablock_a : ABLDEF; LOCAL status; %IF debug %THEN print('anon_log_fao'); %FI/ IF (.ablock_a NEQ 0) AND (.arglst[0] GTR 1) THEN BEGIN BIND+ rab = ablk[ABL_T_RAB] : $RAB_DECL;" status = (IF .arglst[0] GTR 2$ THEN $FAOL( CTRSTR = .arglst[2], OUTLEN = rab[RAB$W_RSZ], OUTBUF = ablk[ABL_Q_BUFDSC], PRMLST = arglst[3])E ELSE $FAO(.arglst[2], rab[RAB$W_RSZ], ablk[ABL_Q_BUFDSC])); IF .status THEN BEGIN $PUT(RAB = rab); %IF debugB %THEN print('anon_log_fao : Message = "!AD"',.rab[RAB$W_RSZ], .rab[RAB$L_RBF]); %FI END; END; SS$_NORMALEND; ! anon_log_fao +GLOBAL ROUTINE init_rdirq (rdirq_a, anon) =BEGIN!++! FUNCTIONAL DESCRIPTION:!H! This routine translates the FTP_DIRS logical and builds a text queue)! of the logical's equivalence strings.!B! RETURNS: cond_value, longword (unsigned), write only, by value! ! PROTOTYPE:!! check_access! ! INPUTS:,! FSPEC: File name or directory descriptor.! Anon: 0,1 for anonymous FTP..! Restrict: Access restrictions for this user.!! IMPLICIT INPUTS: None.!! IMPLICIT OUTPUTS: None.!! COMPLETION CODES:!>! SS$_NORMAL: normal successful completion - access OK.(! any non-success: access not allowed.!! SIDE EFFECTS:! ! None.!-- BIND% rdirq = .rdirq_a : VOLATILE $BBLOCK; LOCAL/ lnmlst1 : VOLATILE $ITMLST_DECL(ITEMS=1),/ lnmlst2 : VOLATILE $ITMLST_DECL(ITEMS=2),* lnmbuf : VOLATILE VECTOR[255, BYTE], lnmlen : VOLATILE WORD, lnmidx : VOLATILE, maxlnm : VOLATILE," tmp_desc : $BBLOCK [DSC$K_S_BLN], status;2 text_init (rdirq); !Initialize the text queue %IF debug1 %THEN print('init_rdirq : In init_rdirq()!'); %FI !J ! Next, check whether the appropriate restrict logical is defined. If# ! not, assume that FSpec is OK. ! $ITMLST_INIT(ITMLST=lnmlst1,I (ITMCOD=LNM$_MAX_INDEX, BUFADR=maxlnm, BUFSIZ=%ALLOCATION(maxlnm))); IF .anon THEN BEGIN %IF debugC %THEN print('init_rdirq : dirs = !AS', anonymous_ftp_dirs_log); %FI status = $TRNLNM(# TABNAM = madgoat_ftp_name_table, ACMODE = exec_mode,# LOGNAM = anonymous_ftp_dirs_log, ITMLST = lnmlst1); END ELSE status = $TRNLNM( TABNAM = LNM$DCL_LOGICAL, LOGNAM = madgoat_ftp_dirs, ITMLST = lnmlst1);# IF NOT .status OR .maxlnm LSS 0A THEN RETURN(SS$_NORMAL); !No restrict dirs, leave queue empty+ tmp_desc [DSC$B_DTYPE] = DSC$K_DTYPE_T;+ tmp_desc [DSC$B_CLASS] = DSC$K_CLASS_S;& tmp_desc [DSC$A_POINTER] = lnmbuf; $ITMLST_INIT(ITMLST=lnmlst2,D (ITMCOD=LNM$_INDEX, BUFADR=lnmidx, BUFSIZ=%ALLOCATION(lnmidx)),D (ITMCOD=LNM$_STRING, BUFADR=lnmbuf, BUFSIZ=%ALLOCATION(lnmbuf), RETLEN=lnmlen)); !G ! Next, loop through the logicals in the restrict list, adding each) ! translation to the directory queue. ! lnmidx = 0;" WHILE (.lnmidx LEQ .maxlnm) DO BEGIN IF .anon THEN status = $TRNLNM(# TABNAM = madgoat_ftp_name_table, ACMODE = exec_mode,# LOGNAM = anonymous_ftp_dirs_log, ITMLST = lnmlst2) ELSE status = $TRNLNM( TABNAM = LNM$DCL_LOGICAL, LOGNAM = madgoat_ftp_dirs, ITMLST = lnmlst2); IF .status THEN BEGIN' tmp_desc [DSC$W_LENGTH] = .lnmlen;# text_append (rdirq, tmp_desc); %IF debug= %THEN print('init_rdirq : Appending = "!AS"', tmp_desc); %FI END; lnmidx = .lnmidx + 1; END;) SS$_NORMAL !Return success to callerEND; .GLOBAL ROUTINE add_to_rdirq (rdirq_a, dsc_a) =BEGIN BIND rdirq = .rdirq_a : TXTDEF, dsc = .dsc_a : $BBLOCK; LOCAL ptr : REF TXTDEF;( IF (.rdirq [TXT_L_FLINK] EQLA rdirq) THEN RETURN (SS$_NORMAL); !H ! See if this string is already in the queue. Do this here insteadH ! of calling text_in_que() for efficiency's sake, since the routine9 ! copies strings around and it's not necessary here. ! ptr = .rdirq [TXT_L_FLINK]; WHILE (.ptr NEQA rdirq) DO BEGIN6 IF (.ptr [TXT_W_LENGTH] EQLU .dsc [DSC$W_LENGTH]) AND  MGFTP023.G|BI[MGFTP.SOURCE]ANON.B32;22K4 7 (CH$EQL (.ptr [TXT_W_LENGTH], .ptr [TXT_A_POINTER],1 .dsc [DSC$W_LENGTH], .dsc [DSC$A_POINTER])) THEN EXITLOOP; ptr = .ptr [TXT_L_FLINK]; END;< IF (.ptr EQLA rdirq) !String wasn't in queue, so add it THEN BEGIN %IF debug3 %THEN print('add_to_dirq : append = !AS', .dsc_a); %FI text_append (rdirq, dsc); END;  RETURN (SS$_NORMAL);END; %SBTTL 'CHECK_ACCESS'@GLOBAL ROUTINE check_access(fspec_a, anon, restrict, rdirq_a) = BEGIN!++! FUNCTIONAL DESCRIPTION:!?! This routine checks to see if the device and directory of aI! file specification are in the list of device/directory specifications>! ok for use by ANONYMOUS. The logical name FTP_DIRS should6! hold that list. If FTP_DIRS does not exist in the?! system logical name table, access is automatically GRANTED.!B! RETURNS: cond_value, longword (unsigned), write only, by value! ! PROTOTYPE:!! check_access! ! INPUTS:,! FSPEC: File name or directory descriptor.! Anon: 0,1 for anonymous FTP..! Restrict: Access restrictions for this user.!! IMPLICIT INPUTS: None.!! IMPLICIT OUTPUTS: None.!! COMPLETION CODES:!>! SS$_NORMAL: normal successful completion - access OK.(! any non-success: access not allowed.!! SIDE EFFECTS:! ! None.!-- BIND- fspec = .fspec_a : $BBLOCK[DSC$K_S_BLN], rdirq = .rdirq_a : TXTDEF; LOCAL nam1_parsed : INITIAL(0),/ lnmlst1 : VOLATILE $ITMLST_DECL(ITEMS=1),/ lnmlst2 : VOLATILE $ITMLST_DECL(ITEMS=2),! fab1 : VOLATILE $FAB_DECL,! nam1 : VOLATILE $NAM_DECL,* espec1 : VOLATILE VECTOR[255, BYTE], fab2 : VOLATILE $FAB_DECL, nam2 : VOLATILE $FAB_DECL,* espec2 : VOLATILE VECTOR[255, BYTE],* lnmbuf : VOLATILE VECTOR[255, BYTE], lnmlen : VOLATILE WORD, lnmidx : VOLATILE, maxlnm : VOLATILE, ptr : REF TXTDEF, status; %IF debug4 %THEN print('check_access : FSPEC = !AS',fspec); %FI !F ! First determine whether we are restricted to the current workingE ! directory. If so, make sure FSpec is in the current directory. !/ IF (.restrict AND FTP$K_RESTRICT_CWD) NEQ 0 THEN BEGIN $NAM_INIT( NAM = nam1, ESA = espec1, ESS = %ALLOCATION(espec1), NOP = ); $FAB_INIT( FAB = fab1, FNA = .fspec[DSC$A_POINTER], FNS = .fspec[DSC$W_LENGTH], DNM = '*.*;*', NAM = nam1);9 IF NOT (status = $PARSE(FAB=fab1)) THEN RETURN(.status);+ nam1_parsed = 1; !Don't reparse this below $NAM_INIT( NAM = nam2, ESA = espec2, ESS = %ALLOCATION(espec2), NOP = ); $FAB_INIT( FAB = fab2, FNM = 'SYS$DISK:[]*.*;*', NAM = nam2);9 IF NOT (status = $PARSE(FAB=fab2)) THEN RETURN(.status);% status = check_directory(nam1,nam2);= IF NOT .status THEN RETURN(.status); !Not in the current dir END;! !K! ! Next, check whether the appropriate restrict logical is defined. If$! ! not, assume that FSpec is OK.! !!! $ITMLST_INIT(ITMLST=lnmlst1,J! (ITMCOD=LNM$_MAX_INDEX, BUFADR=maxlnm, BUFSIZ=%ALLOCATION(maxlnm)));! ! IF .anon ! THEN! BEGIN! %IF debugF! %THEN print('check_access : dirs = !AS', anonymous_ftp_dirs_log);! %FI! status = $TRNLNM($! TABNAM = madgoat_ftp_name_table,! ACMODE = exec_mode,$! LOGNAM = anonymous_ftp_dirs_log,! ITMLST = lnmlst1);! END! ELSE status = $TRNLNM(! TABNAM = LNM$DCL_LOGICAL,! LOGNAM = madgoat_ftp_dirs,! ITMLST = lnmlst1);!$! IF NOT .status OR .maxlnm LSS 0=! THEN RETURN(SS$_NORMAL); !No restrict dirs, grant access !? ! If the restricted directory queue is empty, grant access !$ IF (.rdirq [TXT_L_FLINK] EQLU 0) THEN RETURN (SS$_NORMAL); %IF debugF %THEN print('check_access : logical name defined, making checks'); %FI !@ ! Don't redo parsing the NAM for FSpec if it was done above. !n IF NOT .nam1_parsed  THEN BEGIN $NAM_INIT(S NAM = nam1,i ESA = espec1,o ESS = %ALLOCATION(espec1),$ NOP = ); $FAB_INIT( FAB = fab1, FNA = .fspec[DSC$A_POINTER], FNS = .fspec[DSC$W_LENGTH],1 DNM = '*.*;*', NAM = nam1);9 IF NOT (status = $PARSE(FAB=fab1)) THEN RETURN(.status);i END;i $ITMLST_INIT(ITMLST=lnmlst2,D (ITMCOD=LNM$_INDEX, BUFADR=lnmidx, BUFSIZ=%ALLOCATION(lnmidx)),D (ITMCOD=LNM$_STRING, BUFADR=lnmbuf, BUFSIZ=%ALLOCATION(lnmbuf), RETLEN=lnmlen));' IF NOT .nam1_parsedT THEN $NAM_INIT(N NAM = nam2,_ ESA = espec2,I ESS = %ALLOCATION(espec2), NOP = ); ptr = .rdirq [TXT_L_FLINK];g WHILE (.ptr NEQA rdirq) DO BEGIN $FAB_INIT(E FAB = fab2, FNA = .ptr [TXT_A_POINTER],u FNS = .ptr [TXT_W_LENGTH], DNM = '*.*;*', NAM = nam2); IF $PARSE(FAB=fab2) THENt BEGIN) status = check_directory(nam1,nam2);N7 IF .status THEN RETURN(SS$_NORMAL); !Found a match END;t ptr = .ptr [TXT_L_FLINK]; END;A%( !rJ ! Next, loop through the logicals in the restrict list. If a match is3 ! found, grant access. Otherwise, deny access.f !b lnmidx = 0;  WHILE .lnmidx LEQ .maxlnmy DO BEGIN IF .anon THEN status = $TRNLNM(e# TABNAM = madgoat_ftp_name_table,  ACMODE = exec_mode,# LOGNAM = anonymous_ftp_dirs_log,  ITMLST = lnmlst2) ELSE status = $TRNLNM(f TABNAM = LNM$DCL_LOGICAL, LOGNAM = madgoat_ftp_dirs,. ITMLST = lnmlst2);u IF .status THEN BEGINs $FAB_INIT( FAB = fab2,  FNA = lnmbuf,T FNS = .lnmlen, DNM = '*.*;*', NAM = nam2); IF $PARSE(FAB=fab2) THEN BEGIN6& status = check_directory(nam1,nam2);4 IF .status THEN RETURN(SS$_NORMAL); !Found a match END; END; lnmidx = .lnmidx + 1; END;P)%" RMS$_PRV !No match found aboveEND; ! check_access. u%SBTTL 'CHECK_DIRECTORY'*ROUTINE check_directory(nam1_a, nam2_a) = BEGIND!++ ! FUNCTIONAL DESCRIPTION:!F! This routine is used by check_access to test for directory equality.B! It returns a true (low bit set) value if nam1 refers to the same! directory as nam2.!EA! RETURNS: cond_value, longword(unsigned), write only, by valueR!I ! PROTOTYPE:!V! check_access!_ ! INPUTS:L<! nam1_a : Address of the NAM block for the first directory.=! nam2_a : Address of the NAM block for the second directory.! ! IMPLICIT INPUTS: None.r!! IMPLICIT OUTPUTS: None.a!s! COMPLETION CODES:!s>! SS$_NORMAL: normal successful completion - access OK.(! any non-success: access not allowed.!_! SIDE EFFECTS:_!D ! None.(!--_ BIND nam1 = .nam1_a : $BBLOCK, nam2 = .nam2_a : $BBLOCK; LOCAL_ l1, l2, desc1 : $BBLOCK[DSC$C_S_BLN]* PRESET([DSC$B_CLASS] = DSC$K_CLASS_S,$ [DSC$B_DTYPE] = DSC$K_DTYPE_T), desc2 : $BBLOCK[DSC$C_S_BLN]* PRESET([DSC$B_CLASS] = DSC$K_CLASS_S,$ [DSC$B_DTYPE] = DSC$K_DTYPE_T), f1, f2, match : INITIAL(1),h dots_flag,u status; MACROe" concealed_delim = %STRING('][')%; LITERALk max_devnam = 64,3 concealed_delim_len = %CHARCOUNT(concealed_delim);s EXTERNAL ROUTINE1 STR$MATCH_WILD : BLISS ADDRESSING_MODE(GENERAL); MACRO  get_next_subdir(length, desc)= BEGIN REGISTER tmp_pos;; tmp_pos = CH$FIND_CH(length, .desc[DSC$A_POINTER], %C'.');_ desc[DSC$W_LENGTH] == (IF CH$FAIL  MGFTP023.G|BI[MGFTP.SOURCE]ANON.B32;22K4`((.tmp_pos) THEN length=0 ELSE CH$DIFF(.tmp_pos, .desc[DSC$A_POINTER]));" END%, !End of get_next_subdir new_length(old_length, desc)=' (IF old_length EQL .desc[DSC$W_LENGTH]% THEN 0 !This was the last chunk ELSE BEGIN REGISTER delta;: delta = .desc[DSC$W_LENGTH] + 1; !The amount to shift= desc[DSC$A_POINTER] = CH$PLUS( !Point to the next subdir# .desc[DSC$A_POINTER], .delta);R old_length - .delta! END)%, !End of new_length concealed_dir(length, buffer)=) (IF .length GEQU concealed_delim_len ANDn& CH$EQL(concealed_delim_len, .buffer,/ concealed_delim_len, UPLIT(concealed_delim)) & THEN BEGIN !Found a "][", skip it, length = .length - concealed_delim_len;, buffer = .buffer + concealed_delim_len; 1 !Return success END !End of found "]["f$ ELSE 0)%; !End of concealed_dir4 IF CH$EQL(.nam1[NAM$B_NODE], .nam1[NAM$L_NODE],. .nam2[NAM$B_NODE], .nam2[NAM$L_NODE], %C' ')/ AND(CH$EQL(.nam1[NAM$B_DEV], .nam1[NAM$L_DEV],D0 .nam2[NAM$B_DEV], .nam2[NAM$L_DEV], %C' ')6 OR (.nam1[NAM$B_DEV] NEQ 0 AND .nam2[NAM$B_DEV] NEQ 0 AND (LOCAL status1,R status2,a devnam : $BBLOCK[DSC$C_S_BLN]/ PRESET([DSC$W_LENGTH] = .nam1[NAM$B_DEV],B# [DSC$B_CLASS] = DSC$K_CLASS_S,# [DSC$B_DTYPE] = DSC$K_DTYPE_T, ( [DSC$A_POINTER]= .nam1[NAM$L_DEV]), dev1 : $BBLOCK[max_devnam], dev2 : $BBLOCK[max_devnam]," itmlst : $ITMLST_DECL(ITEMS=1); $ITMLST_INIT(ITMLST=itmlst, (BUFADR = dev1, BUFSIZ = max_devnam,t ITMCOD = DVI$_FULLDEVNAM));8 status1 = $GETDVIW(DEVNAM = devnam, ITMLST = itmlst); IF .status1 THEN BEGIN ' BIND itmptr = itmlst : $BBLOCK;l$ itmptr[ITM$L_BUFADR] = dev2;0 devnam[DSC$W_LENGTH] = .nam2[NAM$B_DEV];1 devnam[DSC$A_POINTER] = .nam2[NAM$L_DEV];= status2 = $GETDVIW(N' DEVNAM = devnam, ITMLST = itmlst);m END; .status1 AND .status2 AND. CH$EQL(max_devnam,dev1, max_devnam,dev2)))) THEN BEGIN l1 = .nam1[NAM$B_DIR]-2;_ l2 = .nam2[NAM$B_DIR]-2;P5 desc1[DSC$A_POINTER] = CH$PLUS(.nam1[NAM$L_DIR], 1); 5 desc2[DSC$A_POINTER] = CH$PLUS(.nam2[NAM$L_DIR], 1);k ! ! Is it [name...]?O !C dots_flag = CH$EQL(3, CH$PLUS(.desc2[DSC$A_POINTER], .l2 - 3), 3, UPLIT('...'));R IF .dots_flag, THEN l2 = .l2 - 2; !Don't compare the ...!BEGIN! !E)! ! Is it-... shorter than requested one?R! !! IF (.l2 - 3) LSS .l1<! THEN l1 = l2 = .nam2[NAM$B_DIR]-4 ! Keep 1 dot(kill 2)&! ELSE l2 = .l2 - 3; ! Kill dots ! END;4! status = CH$EQL(.l1, CH$PLUS(.nam1[NAM$L_DIR], 1),.! .l2, CH$PLUS(.nam2[NAM$L_DIR], 1), %C' '); %IF debug %THEN< print('!%D Test dir:"!AF"',0, .l1, .desc1[DSC$A_POINTER]);< print('!%D Log dir:"!AF"',0, .l2, .desc2[DSC$A_POINTER]); %FI!+! Skip leading 000000 directory references.p!, skip_000000_dirs(l1, desc1[DSC$A_POINTER]);, skip_000000_dirs(l2, desc2[DSC$A_POINTER]); WHILE .l1 GTRU 0 AND .l2 GTRU 0 DO BEGINo? get_next_subdir(.l1, desc1); !Set up a descriptor pointingl> get_next_subdir(.l2, desc2); !...to the next subdirectory %IF debug= %THEN print('!%D Comparing "!AS" to "!AS"',0, desc1, desc2);O %FI( IF NOT STR$MATCH_WILD(desc1, desc2) THEN BEGINM# match = 0; !Record the mismatch.( EXITLOOP; !No need to check any more! END; !End of subdir mismatch_ !! ! Set up for the next iteration.E !@ l1 = new_length(.l1, desc1); !Move to the next subdirectory& l2 = new_length(.l2, desc2); !.../ IF concealed_dir(l1, desc1[DSC$A_POINTER])_= THEN skip_000000_dirs(l1, !Found a concealed dir start,S6 desc1[DSC$A_POINTER]); !...skip leading 000000 dirs/ IF concealed_dir(l2, desc2[DSC$A_POINTER])= THEN skip_000000_dirs(l2, !Found a concealed dir start,t6 desc2[DSC$A_POINTER]); !...skip leading 000000 dirs( END; !End of dir comparison loop IF .match AND .l2 EQL 0 AND6 (.l1 EQL 0 OR .dots_flag) !Got an exact match or the7 THEN RETURN(SS$_NORMAL); !target was a ... directory.I END; !End of device matched1 RETURN(RMS$_PRV); !Directory did not match!END; !End of check_directory %SBTTL 'SKIP_000000_DIRS'a0ROUTINE skip_000000_dirs(length_a, buffer_a_a)= BEGIN !++D! Functional Description:a!;C! This routine takes a string length and buffer address (assumed to B! reference part of a directory string) and skips past any leading! 000000 directory references.!]! Formal Parameters:!a<! length_a - the address of the length longword. It will be8! updated to contain the length - the leading 000000! directories.@! buffer_a_a - the address a longword conataining the address of4! the start of the directory string. It will be/! updated to point after the last "000000."N!--tBIND length = .length_a : LONG,r$ buffer = .buffer_a_a : REF $BBLOCK;MACROI skip_dir = %STRING('000000.')%;LITERALN% skip_dir_len = %CHARCOUNT(skip_dir);E# WHILE .length GEQU skip_dir_lenF DO IF CH$EQL(skip_dir_len, .buffer, skip_dir_len, UPLIT(skip_dir))( THEN BEGIN !Found another 000000 dir3 buffer = .buffer + skip_dir_len; !Skip past itN8 length = .length - skip_dir_len; !Update the length' END !End of found a 000000 dir/ ELSE EXITLOOP; !Out of 000000 dirs, get outd7 RETURN(SS$_NORMAL); !Return status to the callerc"END; !End of skip_000000_dirsENDLELUDOMS: None.!! IMPLICIT OUTPUTS: None.!! COMPLETION CODES:!>! SS$_NO*[MGFTP.SOURCE]CMD_PARSE.B32;5+,2 .$/ 4J$#-I0123KPWO$56Tr7{r89\A#GHJ ! MadGoat FTP client and server!?! Authors: Chad Wilson, Dale Moore, Tod Shannon, Bruce Miller,,! Marc Shannon, Henry Miller, John Clement,1! Matt Madison, Darrell Burkhead, Hunter Goatley!6! Copyright 1986, 1992, Carnegie Mellon University.<! Copyright 1994, MadGoat Software. All rights reserved.!?! Permission is granted for not-for-profit redistribution,?! provided all source and object code remain unchanged from?! the original distribution, and that all copyright notices! remain intact.!MODULE ftpin_parse( ADDRESSING_MODE( EXTERNAL = LONG_RELATIVE," NONEXTERNAL = LONG_RELATIVE),$ LIST(ASSEMBLY, NOBINARY, NOEXPAND), IDENT = 'V2.0') =BEGIN!++>! Cmd_Parse.B32 Copyright (c) 1986 Carnegie Mellon University!! Description:!;! Parse the commands and verify the syntax of each command.!/! Written by: Dale Moore 20-FEB-1986 CMU-CS/RI!! Modifications:!)! V1.1 Hunter Goatley 26-SEP-1993 11:29A! Modified to run under OpenVMS AXP. Mostly, removed references2! to BUILTIN AP and explicitly passed parameters.!--LIBRARY 'SYS$LIBRARY:STARLET';LIBRARY 'SYS$LIBRARY:TPAMAC';LIBRARY 'TPA'; COMPILETIME debug = 0;H%IF debug %THEN %MESSAGE('DEBUG mode is enabled in CMD_PARSE.B32!') %FI; %IF debug%THEN LIBRARY 'NETAUX';%FIMACRO$ PBLOCK_L_ROUTINE = 0, 0, 32, 0%,% PBLOCK_Q_ARGUMENT = 4, 0, 0, 0%;LITERAL PBLOCK_K_SIZE = 12; 1 %SBTTL 'Routines to aid the p  MGFTP023.G2 I[MGFTP.SOURCE]CMD_PARSE.B32;5J$^arsing of commands'MACRO' store_command_macro(routine_name) = EXTERNAL ROUTINE routine_name; !: ! The "param" parameter(parameter #8) is the address of ! the PBlock. ! BIND% pblock = .parameter : $BBLOCK;* pblock[PBLOCK_L_ROUTINE] = routine_name; SS$_NORMAL END%;>TPA_ROUTINE(store_command_user,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(user_command);>TPA_ROUTINE(store_command_pass,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(pass_command);>TPA_ROUTINE(store_command_acct,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(acct_command);>TPA_ROUTINE(store_command_cwd ,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))" store_command_macro(cwd_command);>TPA_ROUTINE(store_command_xcwd,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))" store_command_macro(cwd_command);>TPA_ROUTINE(store_command_cdup,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(cdup_command);>TPA_ROUTINE(store_command_xcup,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(cdup_command);>TPA_ROUTINE(store_command_smnt,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(smnt_command);>TPA_ROUTINE(store_command_quit,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(quit_command);>TPA_ROUTINE(store_command_rein,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(rein_command);>TPA_ROUTINE(store_command_port,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(port_command);>TPA_ROUTINE(store_command_pasv,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(pasv_command);>TPA_ROUTINE(store_command_type,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(type_command);>TPA_ROUTINE(store_command_stru,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(stru_command);>TPA_ROUTINE(store_command_mode,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(mode_command);>TPA_ROUTINE(store_command_retr,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(retr_command);>TPA_ROUTINE(store_command_stor,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(stor_command);>TPA_ROUTINE(store_command_stou,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(stou_command);>TPA_ROUTINE(store_command_appe,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(appe_command);>TPA_ROUTINE(store_command_allo,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(allo_command);>TPA_ROUTINE(store_command_rest,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(rest_command);>TPA_ROUTINE(store_command_rnfr,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(rnfr_command);>TPA_ROUTINE(store_command_rnto,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(rnto_command);>TPA_ROUTINE(store_command_abor,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(abor_command);>TPA_ROUTINE(store_command_dele,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(dele_command);>TPA_ROUTINE(store_command_rmd ,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))" store_command_macro(rmd_command);>TPA_ROUTINE(store_command_xrmd,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))" store_command_macro(rmd_command);>TPA_ROUTINE(store_command_mkd ,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))" store_command_macro(mkd_command);>TPA_ROUTINE(store_command_xmkd,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))" store_command_macro(mkd_command);>TPA_ROUTINE(store_command_pwd ,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))" store_command_macro(pwd_command);>TPA_ROUTINE(store_command_xpwd,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))" store_command_macro(pwd_command);>TPA_ROUTINE(store_command_list,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(list_command);>TPA_ROUTINE(store_command_nlst,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(nlst_command);>TPA_ROUTINE(store_command_site,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(site_command);>TPA_ROUTINE(store_command_syst,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(syst_command);>TPA_ROUTINE(store_command_stat,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(stat_command);>TPA_ROUTINE(store_command_help,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(help_command);>TPA_ROUTINE(store_command_noop,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))# store_command_macro(noop_command); 5TPA_ROUTINE(store_arg,(options, stringcnt, stringptr,0 tokencnt, tokenptr, char, number, parameter))!++! Functional Description:!8! Store an argument to pass along to the remote routine.!! Formal Parameters:!-! The AP points at the TParse argument block.!!-- BIND pblock = .parameter : $BBLOCK; EXTERNAL ROUTINE. STR$COPY_DX : BLISS ADDRESSING_MODE(GENERAL); LOCAL status; %IF debug2 %THEN print('Save command ''!AS''', tokencnt); %FI status = STR$COPY_DX( pblock[PBLOCK_Q_ARGUMENT], tokencnt);( IF NOT .status THEN SIGNAL(.status); SS$_NORMAL END; !++! Description:!2! LIB$TPARSE state tables for FTP server commands.!9! One of the major drawbacks in using LIB$TPARSE, is that@! there is no easy way of doing case blind compares on keywords.!@! So we must have verify routines which set the command and call! the appropriate routines.!!--0$INIT_STATE(ftpin_state_table, ftpin_key_table);$STATE(ftp_command, ((USER), , store_command_user), ((PASS), , store_command_pass), ((ACCT), , store_command_acct), ((CWD) , , store_command_cwd), ((XCWD), , store_command_xcwd), ((CDUP), , store_command_cdup), ((XCUP), , store_command_xcup), ((SMNT), , store_command_smnt), ((QUIT), , store_command_quit), ((REIN), , store_command_rein), ((PORT), , store_command_port), ((PASV), , store_command_pasv), ((TYPE), , store_command_type), ((STRU), , store_comman  MGFTP023.G2 I[MGFTP.SOURCE]CMD_PARSE.B32;5J$ed_stru), ((MODE), , store_command_mode), ((RETR), , store_command_retr), ((STOR), , store_command_stor), ((STOU), , store_command_stou), ((APPE), , store_command_appe), ((ALLO), , store_command_allo), ((REST), , store_command_rest), ((RNFR), , store_command_rnfr), ((RNTO), , store_command_rnto), ((ABOR), , store_command_abor), ((DELE), , store_command_dele), ((RMD) , , store_command_rmd), ((XRMD), , store_command_xrmd), ((MKD) , , store_command_mkd), ((XMKD), , store_command_xmkd), ((PWD) , , store_command_pwd), ((XPWD), , store_command_xpwd), ((LIST), , store_command_list), ((NLST), , store_command_nlst), ((SITE), , store_command_site), ((SYST), , store_command_syst), ((STAT), , store_command_stat), ((HELP), , store_command_help),! ((NOOP), , store_command_noop));$STATE(, (' '), (TPA$_EOS, TPA$_EXIT));$STATE(,( ((command_arg), TPA$_EXIT, store_arg)); $State(command_arg, (TPA$_ANY, command_arg), (TPA$_EOS, TPA$_EXIT));!++D! The TPARSE flags don't have a case insensitive0! match flag. So we must do these crufty hacks.!--$STATE(USER,('U'),('u'));$STATE( ,('S'),('s'));$STATE( ,('E'),('e'));$STATE( ,('R'),('r'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(PASS,('P'),('p'));$STATE( ,('A'),('a'));$STATE( ,('S'),('s'));$STATE( ,('S'),('s'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(ACCT,('A'),('a'));$STATE( ,('C'),('c'));$STATE( ,('C'),('c'));$STATE( ,('T'),('t'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(CWD ,('C'),('c'));$STATE( ,('W'),('w'));$STATE( ,('D'),('d'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(XCWD,('X'),('x'));$STATE( ,('C'),('c'));$STATE( ,('W'),('w'));$STATE( ,('D'),('d'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(CDUP,('C'),('c'));$STATE( ,('D'),('d'));$STATE( ,('U'),('u'));$STATE( ,('P'),('p'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(XCUP,('X'),('x'));$STATE( ,('C'),('c'));$STATE( ,('U'),('u'));$STATE( ,('P'),('p'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(SMNT,('S'),('s'));$STATE( ,('M'),('m'));$STATE( ,('N'),('n'));$STATE( ,('T'),('t'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(QUIT,('Q'),('q'));$STATE( ,('U'),('u'));$STATE( ,('I'),('i'));$STATE( ,('T'),('t'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(REIN,('R'),('r'));$STATE( ,('E'),('e'));$STATE( ,('I'),('i'));$STATE( ,('N'),('n'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(PORT,('P'),('p'));$STATE( ,('O'),('o'));$STATE( ,('R'),('r'));$STATE( ,('T'),('t'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(PASV,('P'),('p'));$STATE( ,('A'),('a'));$STATE( ,('S'),('s'));$STATE( ,('V'),('v'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(TYPE,('T'),('t'));$STATE( ,('Y'),('y'));$STATE( ,('P'),('p'));$STATE( ,('E'),('e'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(STRU,('S'),('s'));$STATE( ,('T'),('t'));$STATE( ,('R'),('r'));$STATE( ,('U'),('u'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(MODE,('M'),('m'));$STATE( ,('O'),('o'));$STATE( ,('D'),('d'));$STATE( ,('E'),('e'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(RETR,('R'),('r'));$STATE( ,('E'),('e'));$STATE( ,('T'),('t'));$STATE( ,('R'),('r'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(STOR,('S'),('s'));$STATE( ,('T'),('t'));$STATE( ,('O'),('o'));$STATE( ,('R'),('r'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(STOU,('S'),('s'));$STATE( ,('T'),('t'));$STATE( ,('O'),('o'));$STATE( ,('U'),('u'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(APPE,('A'),('a'));$STATE( ,('P'),('p'));$STATE( ,('P'),('p'));$STATE( ,('E'),('e'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(ALLO,('A'),('a'));$STATE( ,('L'),('l'));$STATE( ,('L'),('l'));$STATE( ,('O'),('o'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(REST,('R'),('r'));$STATE( ,('E'),('e'));$STATE( ,('S'),('s'));$STATE( ,('T'),('t'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(RNFR,('R'),('r'));$STATE( ,('N'),('n'));$STATE( ,('F'),('f'));$STATE( ,('R'),('r'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(RNTO,('R'),('r'));$STATE( ,('N'),('n'));$STATE( ,('T'),('t'));$STATE( ,('O'),('o'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(ABOR,('A'),('a'));$STATE( ,('B'),('b'));$STATE( ,('O'),('o'));$STATE( ,('R'),('r'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(DELE,('D'),('d'));$STATE( ,('E'),('e'));$STATE( ,('L'),('l'));$STATE( ,('E'),('e'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(RMD ,('R'),('r'));$STATE( ,('M'),('m'));$STATE( ,('D'),('d'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(XRMD,('X'),('x'));$STATE( ,('R'),('r'));$STATE( ,('M'),('m'));$STATE( ,('D'),('d'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(MKD ,('M'),('m'));$STATE( ,('K'),('k'));$STATE( ,('D'),('d'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(XMKD,('X'),('x'));$STATE( ,('M'),('m'));$STATE( ,('K'),('k'));$STATE( ,('D'),('d'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(PWD ,('P'),('p'));$STATE( ,('W'),('w'));$STATE( ,('D'),('d'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(XPWD,('X'),('x'));$STATE( ,('P'),('p'));$STATE( ,('W'),('w'));$STATE( ,('D'),('d'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(LIST,('L'),('l'));$STATE( ,('I'),('i'));$STATE( ,('S'),('s'));$STATE( ,('T'),('t'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(NLST,('N'),('n'));$STATE( ,('L'),('l'));$STATE( ,('S'),('s'));$STATE( ,('T'),('t'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(SITE,('S'),('s'));$STATE( ,('I'),('i'));$STATE( ,('T'),('t'));$STATE( ,('E'),('e'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(SYST,('S'),('s'));$STATE( ,('Y'),('y'));$STATE( ,('S'),('s'));$STATE( ,('T'),('t'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(STAT,('S'),('s'));$STATE( ,('T'),('t'));$STATE( ,('A'),('a'));$STATE( ,('T'),('t'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(HELP,('H'),('h'));$STATE( ,('E'),('e'));$STATE( ,('L'),('l'));$STATE( ,('P'),('p'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT));$STATE(NOOP,('N'),('n'));$STATE( ,('O'),('o'));$STATE( ,('O'),('o'));$STATE( ,('P'),('p'));&$STATE( ,(TPA$_LAMBDA, TPA$_EXIT)); &ROUTINE parse_handler(sig_a, mech_a) = BEGIN BIND sig = .sig_a : $BBLOCK, mech = .mech_a : $BBLOCK; BIND1 condition = sig[CHF$L_SIG_NAME] : LONG UNSIGNED; %IF debug> %THEN print('Parse Handler: Condition = !XL', .condition); %FI SS$_RESIGNAL END; n8GLOBAL ROUTINE parse_ftp_command(string_desc_a, param) =!++n! Functional Description: !nA! Parse the command and get the argument to the command and which,! routine handles the command.!--1 BEGINC ENABLE parse_handler;  BIND( string_desc = .string_desc_a : $BBLOCK; EXTERNAL ROUTINE- LIB$TPARSE : BLISS ADDRESSING_MODE(GENERAL),u. STR$COPY_DX : BLISS ADDRESSING_MODE(GENERAL),/ STR$FREE1_DX : BLISS ADDRESSING_MODE(GENERAL),i unknown_command;l   MGFTP023.G2 I[MGFTP.SOURCE]CMD_PARSE.B32;5J$TG"LOCAL " pblock : $BBLOCK[PBLOCK_K_SIZE],. tparse_block : $BBLOCK[TPA$K_LENGTH0] PRESET( [TPA$L_COUNT] = TPA$K_COUNT0," [TPA$L_OPTIONS] = TPA$M_BLANKS,1 [TPA$L_STRINGCNT] = .string_desc[DSC$W_LENGTH],2 [TPA$L_STRINGPTR] = .string_desc[DSC$A_POINTER], [TPA$L_PARAM] = pblock); BIND0 argument = pblock[PBLOCK_Q_ARGUMENT] : $BBLOCK; LOCALh status; %IF debugy; %THEN print('FTP_Parse_Command: ''!AS''', string_desc); %FI  $INIT_DYNDESC(argument);J status = LIB$TPARSE(tparse_block, ftpin_state_table, ftpin_key_table); IF NOT .status- THEN unknown_command(.param, string_desc)BG ELSE(.pblock[PBLOCK_L_ROUTINE])(.param, pblock[PBLOCK_Q_ARGUMENT]);L STR$FREE1_DX(argument);e SS$_NORMAL END;END ELUDOM CMD_PARSE.B32!') %FI; %IF debug%THEN LIBRARY 'NETAUX';%FIMACRO$ PBLOCK_L_ROUTINE = 0, 0, 32, 0%,% PBLOCK_Q_ARGUMENT = 4, 0, 0, 0%;LITERAL PBLOCK_K_SIZE = 12; 1 %SBTTL 'Routines to aid the p*[MGFTP.SOURCE]CONDITION.B32;1+,I./ 4N-I0123KPWO567(ړ89\A#GHJ ! MadGoat FTP client and server!?! Authors: Chad Wilson, Dale Moore, Tod Shannon, Bruce Miller,,! Marc Shannon, Henry Miller, John Clement,1! Matt Madison, Darrell Burkhead, Hunter Goatley!6! Copyright 1986, 1992, Carnegie Mellon University.<! Copyright 1994, MadGoat Software. All rights reserved.!?! Permission is granted for not-for-profit redistribution,?! provided all source and object code remain unchanged from?! the original distribution, and that all copyright notices! remain intact.!MODULE condition( ADDRESSING_MODE( EXTERNAL = LONG_RELATIVE," NONEXTERNAL = LONG_RELATIVE), IDENT = 'V2.1',& LIST(ASSEMBLY, NOBINARY, NOEXPAND)) =BEGIN!++! Description:!<! Some routines for the FTP utility to manage how errors and!! special conditions are handled.! ! Written By:!"! Dale Moore CMU-CS/RI 12-OCT-1987!! Modifications:!*! V2.1 Darrell Burkhead 7-JUN-1994 15:34<! Replaced the $EXIT call in do_exit with a more controlled! exit.!&! V1.0 21-SEP-1993 Hunter Goatley WKU-! Ported to run under OpenVMS AXP(using UCX).!--LIBRARY 'SYS$LIBRARY:STARLET';LIBRARY 'FTP_MSG';LIBRARY 'CLI';LIBRARY 'NETAUX';LITERAL cond_abort = 0, cond_continue = 1, cond_exit = 2;OWN, cntrl_c_condition : INITIAL(cond_abort),* error_condition : INITIAL(cond_abort),+ severe_condition : INITIAL(cond_abort),/ warning_condition : INITIAL(cond_continue); !ROUTINE do_abort(sig_a, mech_a) =!++! Functional Description:!4! From the status of the various condition settings,<! I'm suppose to abort whatever I'm doing and go to the FTP> ! prompt.!-- BEGIN BIND sig = .sig_a : $BBLOCK, mech = .mech_a : $BBLOCK; BIND5%IF %BLISS(BLISS32E) %THEN !If compiling for AXP...( sig_args = sig[CHF$IS_SIG_ARGS] : LONG,( sig_name = sig[CHF$IS_SIG_NAME] : LONG,%ELSE' sig_args = sig[CHF$L_SIG_ARGS] : LONG,' sig_name = sig[CHF$L_SIG_NAME] : LONG,%FI& sig_name_block = sig_name : $BBLOCK; sig_args = .sig_args - 2; $PUTMSG(MSGVEC = sig);1%IF %BLISS(BLISS32E) %THEN !Put the value in R0+ mech[CHF$IL_MCH_SAVR0_LOW] = .sig_name;%ELSE& mech[CHF$L_MCH_SAVR0] = .sig_name;%FI SETUNWIND() END; ROUTINE do_continue(sig_a) =!++! Functional Description:!E! Merely display the message and continue as though nothing happened.!-- BEGIN BIND sig = .sig_a : $BBLOCK,' sig_args = sig[CHF$L_SIG_ARGS] : LONG; sig_args = .sig_args - 2; $PUTMSG(MSGVEC = sig); SS$_CONTINUE END; ROUTINE do_exit(sig_a) =!++! Functional Description:!5! Display the error message and exit the FTP utility.!-- BEGIN BIND sig = .sig_a : $BBLOCK,' sig_args = sig[CHF$L_SIG_ARGS] : LONG,' sig_name = sig[CHF$L_SIG_NAME] : LONG; EXTERNAL exit_flag, exit_status; sig_args = .sig_args - 2; $PUTMSG(MSGVEC = sig); exit_flag = 1;/ exit_status = .sig_name OR STS$M_INHIB_MSG; SIGNAL(RMS$_EOF); SS$_NORMAL END; :GLOBAL ROUTINE ftp_routine_handler(sig_a, mech_a, ena_a) =!++! Functional Description:!>! Here is where we check the condition that has been raised or:! signalled. If it is something that we check for then we!! see what we are to do about it.!!-- BEGIN BIND sig = .sig_a : $BBLOCK, mech = .mech_a : $BBLOCK, ena = .ena_a : $BBLOCK; BIND' sig_args = sig[CHF$L_SIG_ARGS] : LONG,' sig_name = sig[CHF$L_SIG_NAME] : LONG,& sig_name_block = sig_name : $BBLOCK;9 IF .sig_name EQLU SS$_UNWIND THEN RETURN(SS$_NORMAL);= IF .sig_name EQLU SS$_ACCVIO THEN RETURN( SS$_RESIGNAL );K IF(.sig_name EQL FTP$_CONTROL_C) AND(.cntrl_c_condition EQL cond_abort)% THEN RETURN(do_abort(sig, mech));N IF(.sig_name EQL FTP$_CONTROL_C) AND(.cntrl_c_condition EQL cond_continue) THEN RETURN(SS$_CONTINUE);J IF(.sig_name EQL FTP$_CONTROL_C) AND(.cntrl_c_condition EQL cond_exit) THEN RETURN(do_exit(sig));; IF(.sig_name_Block[STS$V_SEVERITY] EQL STS$K_ERROR) AND" (.error_condition EQL cond_abort)% THEN RETURN(do_abort(sig, mech));; IF(.sig_name_Block[STS$V_SEVERITY] EQL STS$K_ERROR) AND% (.error_condition EQL cond_continue)" THEN RETURN(do_continue(sig));; IF(.sig_name_Block[STS$V_SEVERITY] EQL STS$K_ERROR) AND! (.error_condition EQL cond_exit) THEN RETURN(do_exit(sig));< IF(.sig_name_Block[STS$V_SEVERITY] EQL STS$K_SEVERE) AND# (.severe_condition EQL cond_abort)% THEN RETURN(do_abort(sig, mech));< IF(.sig_name_Block[STS$V_SEVERITY] EQL STS$K_SEVERE) AND& (.severe_condition EQL cond_continue)" THEN RETURN(do_continue(sig));< IF(.sig_name_Block[STS$V_SEVERITY] EQL STS$K_SEVERE) AND" (.severe_condition EQL cond_exit) THEN RETURN(do_exit(sig));= IF(.sig_name_Block[STS$V_SEVERITY] EQL STS$K_WARNING) AND$ (.warning_condition EQL cond_abort)% THEN RETURN(do_abort(sig, mech));= IF(.sig_name_Block[STS$V_SEVERITY] EQL STS$K_WARNING) AND' (.warning_condition EQL cond_continue)" THEN RETURN(do_continue(sig));= IF(.sig_name_Block[STS$V_SEVERITY] EQL STS$K_WARNING) AND# (.warning_condition EQL cond_exit) THEN RETURN(do_exit(sig)); SS$_RESIGNAL END; GLOBAL ROUTINE!++! Functional Description:!:! A CLI dispatch routine. Tells what to do in the case of! a Control-C.!--9 on_controlc_abort = (cntrl_c_condition = cond_abort),? on_controlc_continue = (cntrl_c_condition = cond_continue),7 on_controlc_exit = (cntrl_c_condition = cond_exit); GLOBAL ROUTINE!++! Functional Description:!:! A CLI dispatch routine. Tells what to do in the case of ! an Error!--4 on_error_abort = (error_condition = cond_abort),: on_error_continue = (error_condition = cond_continue),2 on_error_exit = (error_condition = cond_exit); GLOBAL ROUTINE!++! Functional Description:!:! A CLI dispatch routine. Tells what to do    MGFTP023.GII[MGFTP.SOURCE]CONDITION.B32;1Nͬ in the case of! a Severe Error!--5 on_severe_abort =(severe_condition = cond_abort),; on_severe_continue =(severe_condition = cond_continue),3 on_severe_exit =(severe_condition = cond_exit); GLOBAL ROUTINE!++! Functional Description:!:! A CLI dispatch routine. Tells what to do in the case of ! a Warning!--7 on_warning_abort =(warning_condition = cond_abort),= on_warning_continue =(warning_condition = cond_continue),5 on_warning_exit =(warning_condition = cond_exit); GLOBAL ROUTINE show_conditions =!++! Functional Description:!7! Display for the user what the current settings of the.! various condition handling arrangements are.!-- BEGIN# SELECTONE .cntrl_c_condition OF SET- [cond_abort] : Print('ON Control_C Abort');3 [cond_continue] : Print('ON Control_C Continue');+ [cond_exit] : Print('ON Control_C Exit'); TES;! SELECTONE .error_condition OF SET) [cond_abort] : Print('ON Error Abort');/ [cond_continue] : Print('ON Error Continue');' [cond_exit] : Print('ON Error Exit'); TES;" SELECTONE .severe_condition OF SET* [cond_abort] : Print('ON Severe Abort');0 [cond_continue] : Print('ON Severe Continue');( [cond_exit] : Print('ON Severe Exit'); TES;# SELECTONE .warning_condition OF SET+ [cond_abort] : Print('ON Warning Abort');1 [cond_continue] : Print('ON Warning Continue');) [cond_exit] : Print('ON Warning Exit'); TES; SS$_NORMAL END;ENDELUDOM*[MGFTP.SOURCE]CONTROL_C.B32;1+,I./ 4L-I0123KPWO56~!ӗ789\A#GHJ  ! MadGoat FTP client and server!?! Authors: Chad Wilson, Dale Moore, Tod Shannon, Bruce Miller,,! Marc Shannon, Henry Miller, John Clement,1! Matt Madison, Darrell Burkhead, Hunter Goatley!6! Copyright 1986, 1992, Carnegie Mellon University.<! Copyright 1994, MadGoat Software. All rights reserved.!?! Permission is granted for not-for-profit redistribution,?! provided all source and object code remain unchanged from?! the original distribution, and that all copyright notices! remain intact.!MODULE control_c( ADDRESSING_MODE( EXTERNAL = LONG_RELATIVE," NONEXTERNAL = LONG_RELATIVE), IDENT = 'V2.0',& LIST(ASSEMBLY, NOBINARY, NOEXPAND)) =BEGIN!++! Control_C.B32!.! Copyright(C) 1987 Carnegie Mellon University!! Description:!0! A module to try and trap and handle control-C.! For the FTP Utility.! ! Written By:!! Chad Wilson CMU-CS/RI!! Modifications:!!--LIBRARY 'SYS$LIBRARY:STARLET';LIBRARY 'FTP_MSG';OWN) term_chan : WORD UNSIGNED INITIAL(0); FORWARD ROUTINE setup_control_c;ROUTINE control_c_ast(astprm) =!++! Functional Description:!9! A Control-C has been typed. ReEnable for another, then=! SIGNAL the condition, which will probably unwind the stack.!-- BEGIN EXTERNAL quiet_flag; setup_control_c(); $WAKE(); signal(FTP$_CONTROL_C); SS$_NORMAL END; ROUTINE setup_control_c =!++! Functional Description:!-- BEGIN LOCAL status; status = $QIOW( CHAN = .term_chan,& FUNC = IO$_SETMODE OR IO$M_CTRLCAST, P1 = control_c_ast);7 IF NOT .status THEN SIGNAL(FTP$_ERROR, 0, .status); SS$_NORMAL END; GLOBAL ROUTINE init_control_c =!++! Functional Description:!5! Will set up the I/O request for the control-c trap.!!-- BEGIN EXTERNAL ROUTINE- LIB$GETDVI : BLISS ADDRESSING_MODE(GENERAL); LOCAL dev_type : LONG UNSIGNED, status; !++* ! See if we've already started things. !--1 IF .term_chan NEQU 0 THEN RETURN(SS$_NORMAL);2 status = $ASSIGN( DEVNAM = %ASCID'SYS$INPUT:', CHAN = term_chan);7 IF NOT .status THEN SIGNAL(FTP$_ERROR, 0, .status);L status = LIB$GETDVI(%REF(DVI$_DEVCLASS), %REF(.term_chan), 0, dev_type);7 IF NOT .status THEN SIGNAL(FTP$_ERROR, 0, .status); !++; ! If device isn't terminal, don't start control-C trap !--7 IF .dev_type NEQU DC$_TERM THEN RETURN(SS$_NORMAL); setup_control_c(); SS$_NORMAL END; #GLOBAL ROUTINE clean_up_control_c =!++! Functional Description:!3! Will cancel I/O request and deassign the channel.!-- BEGIN LOCAL status;( status = $CANCEL(CHAN = .term_chan);( IF NOT .status THEN SIGNAL(.status);( status = $DASSGN(CHAN = .term_chan);( IF NOT .status THEN SIGNAL(.status); SS$_NORMAL END;ENDELUDOM)*[MGFTP.SOURCE]COPY_DIR_FTP_SUPPORT.B32;18+,= . / 4M -I0123KPWO!56IXt7IXt89\A#GHJ%TITLE 'COPY_DIR_FTP_SUPPORT'MODULE COPY_DIR_FTP_SUPPORT (#%IF %VARIANT %THEN MAIN = main, %FI ADDRESSING_MODE ( EXTERNAL = LONG_RELATIVE," NONEXTERNAL = LONG_RELATIVE),IDENT = 'V1.0') = BEGIN!++!!! Facility: COPY_DIR_FTP_SUPPORT!! Author: Hunter Goatley!! Date: August 13, 1996! ! Abstract:!>! Routines that allow MadGoat FTP to be called via the VMS DCL ! commands COPY/FTP and DIR/FTP.!! Modified by:!+! 01-000 Hunter Goatley 13-AUG-1996 11:25! Original version.!!--9LIBRARY 'SYS$LIBRARY:STARLET'; !Pull stuff from STARLET4LIBRARY 'SYS$LIBRARY:TPAMAC'; !Pull stuff from LIBLIBRARY 'TPA';LIBRARY 'CLI'; FORWARD ROUTINE %IF %VARIANT%THEN main, !Main entry point%FI parse_nodespec, node_store, build_copy_string, build_dir_string ; EXTERNAL ROUTINE) STR$COPY_DX : ADDRESSING_MODE (GENERAL),( LIB$TPARSE : ADDRESSING_MODE (GENERAL),) LIB$SYS_FAO : ADDRESSING_MODE (GENERAL),, LIB$PUT_OUTPUT : ADDRESSING_MODE (GENERAL),- LIB$GET_COMMAND : ADDRESSING_MODE (GENERAL),( STR$COPY_R : ADDRESSING_MODE (GENERAL),) CLI$PRESENT : ADDRESSING_MODE (GENERAL),+ CLI$GET_VALUE : ADDRESSING_MODE (GENERAL),( STR$APPEND : ADDRESSING_MODE (GENERAL),( STR$CONCAT : ADDRESSING_MODE (GENERAL),) LIB$SYS_FAO : ADDRESSING_MODE (GENERAL),- STR$COMPARE_EQL : ADDRESSING_MODE (GENERAL),) STR$FREE1_DX : ADDRESSING_MODE (GENERAL) ; EXTERNAL LITERAL FTP$_DIRFTPNOHOST, FTP$_COPFTPNOBOTH, FTP$_COPFTPNOLOCAL, FTP$_IGNORFDL; BIND null_str = %ASCID'',( blank_str = %ASCID %STRING(%CHAR(32)), p1_str = %ASCID'P1', p2_str = %ASCID'P2',$ anonymous_str = %ASCID'ANONYMOUS',) anonymous_qual_str = %ASCID'/ANONYMOUS', doublequote_str = %ASCID'"',) username_qual_str = %ASCID'/USERNAME="',) password_qual_str = %ASCID'/PASSWORD="', log_qual_str = %ASCID'/LOG', log_str = %ASCID'LOG', ascii_str = %ASCID'ASCII', binary_str = %ASCID'BINARY',' type_ascii_str = %   MGFTP023.G= I)[MGFTP.SOURCE]COPY_DIR_FTP_SUPPORT.B32;18M MASCID'/TYPE=ASCII',( type_binary_str = %ASCID'/TYPE=IMAGE', fdl_str = %ASCID'FDL'; MACRO' TPA_A_P1 = TPA$C_LENGTH0+00,0,32,0%,' TPA_A_P2 = TPA$C_LENGTH0+04,0,32,0%,' TPA_A_P3 = TPA$C_LENGTH0+08,0,32,0%,' TPA_A_P4 = TPA$C_LENGTH0+12,0,32,0%,' TPA_A_P5 = TPA$C_LENGTH0+16,0,32,0%,' TPA_A_P6 = TPA$C_LENGTH0+20,0,32,0%,' TPA_A_P7 = TPA$C_LENGTH0+24,0,32,0%,' TPA_A_P8 = TPA$C_LENGTH0+28,0,32,0%;' $INIT_STATE (NODE_STATE, NODE_KEY); $STATE (START, (TPA$_BLANK, START), ('"', USER), (':', COLON),$ (TPA$_ANY, START, NODE_STORE,,,1)); $STATE (USER, (TPA$_BLANK, PASS), ('"', START),# (TPA$_ANY, USER, NODE_STORE,,,2)); $STATE (PASS, (TPA$_BLANK, PASS), ('"', START),# (TPA$_ANY, PASS, NODE_STORE,,,3)); $STATE (COLON, (':', REST), (TPA$_ANY, TPA$_FAIL)); $STATE (REST, (TPA$_BLANK, REST), (TPA$_EOS, TPA$_EXIT),# (TPA$_ANY, REST, NODE_STORE,,,4)); JGLOBAL ROUTINE parse_nodespec (string_a, node_a, user_a, pass_a, rest_a) =BEGIN!+! Function: PARSE_NODESPEC!! Functional description:!>! This routine calls LIB$TPARSE to parse a DECnet-style remoteA! file spec and return the nodename, username, password, and file! portions to the caller.!.! The format expected is one of the following:!C! node::[file] node"user"::[file] node"user pass"::[file]!=! The file spec is not parsed, because it may be a UNIX-style+! file spec, complete with directory names.!!! Input arguments:!5! string_a - Address of descriptor of string to parse=! node_a - Address of dynamic descriptor to receive nodename=! user_a - Address of dynamic descriptor to receive username=! pass_a - Address of dynamic descriptor to receive password8! rest_a - Address of dynamic descriptor to receive the!! remainder of the file spec.! ! Returns:!! SS$_NORMAL - Normal success8! FTP$_COPFTPNOBOTH - Error: Both file specs were remote8! FTP$_COPFTPNOLOCAL - Error: Both file specs were local!!- LITERAL# TPA_C_LENGTH = TPA$C_LENGTH0 + 32, TPA_K_COUNT = TPA$K_COUNT0 + 8; BIND string = .string_a : $BBLOCK, node = .node_a : $BBLOCK, user = .user_a : $BBLOCK, pass = .pass_a : $BBLOCK, rest = .rest_a : $BBLOCK; LOCAL" TPABLK : $BBLOCK [TPA_C_LENGTH], node_buf : $BBLOCK [1024], user_buf : $BBLOCK [1024], pass_buf : $BBLOCK [1024], rest_buf : $BBLOCK [1024],( node_len, user_len, pass_len, rest_len, test : $BBLOCK [DSC$K_S_BLN], count, status; BUILTIN ACTUALCOUNT;2 user_len = node_len = pass_len = rest_len = 0;' TPABLK [TPA$L_COUNT] = TPA_K_COUNT; TPABLK [TPA$L_OPTIONS] = 0; TPABLK [TPA$V_BLANKS] = 1;6 TPABLK [TPA$L_STRINGCNT] = .string [DSC$W_LENGTH];7 TPABLK [TPA$L_STRINGPTR] = .string [DSC$A_POINTER];! TPABLK [TPA_A_P1] = node_len;! TPABLK [TPA_A_P2] = node_buf;! TPABLK [TPA_A_P3] = user_len;! TPABLK [TPA_A_P4] = user_buf;! TPABLK [TPA_A_P5] = pass_len;! TPABLK [TPA_A_P6] = pass_buf;! TPABLK [TPA_A_P7] = rest_len;! TPABLK [TPA_A_P8] = rest_buf;7 status = LIB$TPARSE (tpablk, node_state, node_key);' IF NOT .status THEN RETURN .status; count = ACTUALCOUNT(); IF (.count EQLU 1) THEN RETURN (.status);( IF (.count GEQU 2) AND (node NEQA 0) THEN' STR$COPY_R (node, node_len, node_buf);( IF (.count GEQU 3) AND (user NEQA 0) THEN' STR$COPY_R (user, user_len, user_buf);( IF (.count GEQU 4) AND (pass NEQA 0) THEN' STR$COPY_R (pass, pass_len, pass_buf);( IF (.count GEQU 5) AND (rest NEQA 0) THEN' STR$COPY_R (rest, rest_len, rest_buf);, RETURN (.status); !Set success statusEND; !End of routine FTPA_ROUTINE (NODE_STORE, (OPTIONS, STRLEN, STRPTR, TOKLEN, TOKPTR, CH,J NUMBER, PARAM, NLEN_A, NBUF_A, ULEN_A, UBUF_A, PLEN_A, PBUF_A, rlen_a, rbuf_a))!+! Function: NODE_STORE!! Functional description:!:! This routine is called by LIB$TPARSE to store the parsed(! characters in the appropriate buffers.!! Input arguments:!! TPARSE parameters! ch - Character to store@! nlen_a - Address of length of node name stored in node buffer'! nbuf_a - Address of node name buffer?! ulen_a - Address of length of username stored in user buffer&! ubuf_a - Address of username buffer>! plen_a - Address of length of password stored in pwd buffer&! pbuf_a - Address of password buffer@! rlen_a - Address of length of rest of string stored in buffer,! rbuf_a - Address of rest of string buffer! ! Returns:!! SS$_NORMAL - Normal success8! FTP$_COPFTPNOBOTH - Error: Both file specs were remote8! FTP$_COPFTPNOLOCAL - Error: Both file specs were local!!- BIND char = CH : BYTE, nlen = .nlen_a, nbuf = .nbuf_a : VECTOR[,BYTE], ulen = .ulen_a, ubuf = .ubuf_a : VECTOR[,BYTE], plen = .plen_a, pbuf = .pbuf_a : VECTOR[,BYTE], rlen = .rlen_a, rbuf = .rbuf_a : VECTOR[,BYTE]; !B ! Depending on the value in PARAM, store the character in the2 ! appropriate buffer and increase the length. ! CASE (.param) FROM 1 TO 4 OF SET/ [1] : nbuf [(nlen = .nlen+1)-1] = .char; !Node3 [2] : ubuf [(ulen = .ulen+1)-1] = .char; !Username3 [3] : pbuf [(plen = .plen+1)-1] = .char; !Password3 [4] : rbuf [(rlen = .rlen+1)-1] = .char; !The rest TES; SS$_NORMALEND; *GLOBAL ROUTINE build_copy_string (cmd_a) =BEGIN!+! Function: BUILD_COPY_STRING!! Functional description:!A! This routine is called to check the COPY/FTP command qualifiers?! and build a new MGFTP command line that will be parsed by theE! caller. Instead of providing internal CLD support for the COPY/FTPB! command, we just make a new command line that makes it look like"! the user invoked MGFTP directly.!! Input arguments:!7! cmd_a - Address of dynamic descriptor to receive the! MGFTP command line. ! Returns:!! SS$_NORMAL - Normal success8! FTP$_COPFTPNOBOTH - Error: Both file specs were remote8! FTP$_COPFTPNOLOCAL - Error: Both file specs were local!!- BIND cmd = .cmd_a : $BBLOCK; LOCAL str : $BBLOCK [DSC$K_S_BLN]," fromstr : $BBLOCK [DSC$K_S_BLN], tostr : $BBLOCK [DSC$K_S_BLN], node : $BBLOCK [DSC$K_S_BLN], user : $BBLOCK [DSC$K_S_BLN], pass : $BBLOCK [DSC$K_S_BLN],# ftp_quals : $BBLOCK [DSC$K_S_BLN], ffile : $BBLOCK [DSC$K_S_BLN], log, status; $INIT_DYNDESC (str); $INIT_DYNDESC (fromstr); $INIT_DYNDESC (tostr); $INIT_DYNDESC (node); $INIT_DYNDESC (user); $INIT_DYNDESC (pass); $INIT_DYNDESC (ffile); $INIT_DYNDESC (ftp_quals);- status = CLI$GET_VALUE (p1_str, fromstr);+ status = CLI$GET_VALUE (p2_str, tostr); log = CLI$PRESENT (log_str);? status = parse_nodespec (fromstr, node, user, pass, ffile); IF (.status) THEN BEGIN IF (parse_nodespec (tostr)) THEN RETURN (FTP$_COPFTPNOBOTH); !A ! Here, the source file contains the remote host name, so we're% ! doing a GET from the remote node. !0 LIB$SYS_FAO (%ASCID'GET!AS!AS !AS !AS', 0, str,- (IF .log THEN log_qual_str ELSE null_str), !7 ! The default is /ASCII for PUT. If user specified6 ! /BINARY on command line, then add /TYPE=IMAGE to ! PUT command. !! (IF (CLI$PRESENT (binary_str))( THEN type_binary_str ELSE null_str), ffile, tostr); END ELSE BEGIN: status = parse_nodespec (tostr, node, user, pass, ffile); I[MGFTP.SOURCE]C@AE>Z5%08)qbbk~RT.B32;18A,2X[,(c>@ASN/s+</DM;b HbH)\(@G/oBI SM)Z# *sQ~ +%h07F:sXZ*]y1QDb{/wR(2+ %Q{bp_E>d [uZfa4IQ0Lr}2VFQxy;^r~h}v`?]L!h|xlD]RuB-!'ZmJa]GeOy;Co\>e.= LxxAr]fM]e! ҳjF$A%dA{bTnwo%+O"M@v^k7[8 krBR[e-UGs[xRGBWGF>8_4~'n,;+J;@g%=j{ ~'mPVh>s;TpRN VG72Y0*d%~ gcNhHOZqp3a,VhXK|,op}H4jSWBwCwsQTv7}%K~^H` zk_ntH gSW#@ A)gJnG8ul2MT+~i{cz!rkE3n$-X&ivSp &~^) s49^~h`bQYT`Y*XuheUL?lJ D~S6| J l0JQ" h>N@!_72u~5^\_[Qe~^Yl:]hW{Kh]b poq H,lP@\?8W+3ZCzA&e=Q>8dfqhcqJ !Z (i?KH)elES6.e8F)T-;Z^iVl uuA\S a+Qs) `KcCqhF+! }pBjwq~t8zsAxxF+' /[UT'ZfEKC#2B[oHjtp6g-74(OS3UT1y*Y":N -{:8&F K/5WN]ZO)}px 2y9% fNuW/m=_]2M3ncZ{%YWv+ #^.{LUq5x&[ '@6irt*AK\vIod/!NP`2_{I{`d{HJ8PqN^i-Bs4{KH-ME`=?TW/o^GSqd(I,CfH{}id9C wJ%(C|I1}a6Hgn`b|3{4MlkE$HvS gB)[nVm!1puD\pf3y?pM9s[q7gHR4$*" @KscS%DvcT3umht6D/*1+oQy}: "z] )-&)aH;\ ͥ;^MD+Ș\9 jCU;G\ `qE?uLA\`Hc'SR9\^?aOp .]3Wu B~Ecc{}%AFjE,oci.(Y"bCQD'#`!1O7he:.E{;B~x sU2Ovdn&][pbbc)j0 g0a*#E: `uM#rp6$^Vm.)ZACgt:&8 )L%(dacQf gj+"c%z/ s@?q~kzJ*+AF"Sz"wv,\Reai^L7 rot-K-v-l!]Uz#\ =|.gs[([em1WO.*Ln02KBK0zT hM')K1E@?'*.&QE0-D{[jp 3$G<`8w!ZaG$i8g1,a ou]Ba}xd?59gn HBi0pFb0b'+(chGlO[*vScRQLFY GG[^Mb\z1Z2^3'W1U}hC+1z %n_yTm5C%/rX[E$l5iu L5;,v~F YMxiar a:9AK5. 1M ,t5}!p,v2 jxE&T?bGf;Lc, bPY|*_I~?YQ.HxBxH-+wZ &A`|l[U8WYw 4=&>L%c MrffY ]'ad]uvf8mm 9%1X-y,byVJ'd81B_=Jm/AU?BcQ8grBe~1BR~^OquN3.jaXCCR2.zY4)UQ$40D=^,?DG(^!LQ}*VX|i/WbSu{eegM.)izG"mr|en;~mjV_iz'-# n@"D*_?K*b ^.HHPp;$.+mQtF|9l5z&0N|f%jMx(;d1 k]`Pm&5bD'#}'\n~/='MHYf WXIaXahMIt1w01?ZjlRV{Wsx'P`l]2C7XwQ?*VW5;e\:oQ;|*qrAyML7J{ fV11oOnM8hw7XhE%I\!wB3: $v^ jJa;j_%jz 5%!PVx ("F|6)9>9o<8|v|)Cd2. ,6* \(?~.ld(0-j>{g,Li'af~%[hY: #Ai nڞBbN}e!XL#` aP=U+U{uudt.'i =sl^ ~awlbM`aFI@BnKi+Zooc k R**6G)E\!EKWCg<389J:]!6/b%WN;:G j|u_dO7vMiG|z6ZpmV/:U^36xmC\LJO[YHs 1ZZ" 2>3hck&EXC2 z{7%gg\4$aV~%\(OZ4fPu:NmE*-1+-hSn S 8!_a)AX$Zf) (VyLzvJ{gtb?3A%`G@xQsM>H)i)dnC2fFr+(rd}#@ / tzkQit;OTi u5*?C!y8]fu":Yl h}da5d?#!-H=tU2F"}j-`YZC&h/=vnnJ,c>3n?5+M m'cM}n`>Pi< Ug_Z"f$G8%-vXJ^Q[R'= 5Q!*!I+Jf1y-&g3\Zt6lP.^>d:,752)3]$~*H'VN8Ugen(nd]8 l Q& &7Sm"pz@Viqh: jMkw+"0#5\oZt?m?Buzt&jsnHASy<ZM,HjS;|.'MiYzRPz'3M@ulC QYzUdD+<I:^YvDE#k~Rhp8 Z'C0*{TUwOB3Q|L7an-Y}t,wg C>o-Rh;5wz_>w$|zRPC4JMLeHOf?oL%&jL-t5OI?N#xz2Gs7a+YzΧC^U9,ho}H$lM#u6hS6 'A8nx\{3Q bkcn(/D>U-P2I&:NngDFk}p0-#:B_f4K.HPG$-!$8MB2R h_+-D)Re4LY`.x6@ &$H 6W.rYklkqxo>X2V SA]*s$es*uii]Jrryr|cFu,1h!z4o+-:CR:AovDWIkF I:UOhS\D]-n/'C=qgI]V/S`gC9#KnmSofn1$o N:XYk {^F P$[r=/]! },%f:]E<Cs@2F7E$'}M U Z^|Y0 HVJ9='] $ Y~Suz's uQa5bX tss4H3Mt{U\$# ); yBy#j,Og^H;}Bu#_]|ntP1{>s \uwL;;0?+{}f(S[m1&w0t`dB>(fMuNX_er/t$"%u0l,A'16H?!Dp/iS P$ot1TW(=<2q(mHO). '-P)z-l 3 bPESx{K0P]d,K:\I!FWw-308g`Cg_!_V Or`r^E:|Xt A 3n5l~$3)R}iB7&*!j[""u[_CNk8Yftoi N:h 7K -TU}e H+OfRG-/I66[YA$b^$>s-ET U+S1YXZ="OGM^QB}&oMi]8yoX&thCKA+ k .-{h><@QHgy}0J}kYJAAQ wR3roU s@gFe[2K{m0 p?Oftn!z=HBGlYO4!&Zt-6.CSsAdx K_*$cs%BJkx1HkA>WGP2@|.]8MS 'A7r147+!#t<'L]o1yL^;|x/L:9@Tv=c56= SmBk.2;e|`x-Qa %47 N1mX\#.qieFx?ZkgukS6aY ?RS86Xl $31'z?\#K$U__K@uj;-!f>tZRD~M)_{}Aa3#{ =Z3>S<>yOpBwt(pJ-HvV_Y ( 69=Zg<,n= GqV$iJE!78<x\-~WCb_C3X)0hg"q];T'Dp K`IB5uM>b f,X"?mw[x_b?H7@*in[(FHfYMv{ (0<B#.7t8iCoP_3k,k/gz>R}Wk 88J2{i5B] Dr*)n\Qg!QS(cu=_^d WK Vm VVd^@l51yyp~!deCXc5r={I7S&9%HUyk_]t!:45LPtE8{ch5|/#fpwhT3aQQteiTF wkSL 4UKp2-f||.d=&7>! XX0:)?`(agYN4jCp {v/37&,&\Hq_ seeN_=e MVqS8}_$%a7&z8PP_Lq-_BK 0LBX$P&ec 10ubKVZmavS:|@YU .oDueIpuG3I00ey 4w}BDE5scy{;I.bC` &P4ytob8H&c}jJqU}k\6;h^3?w[`Y&oZ[FogxohBa77%+cJK taGv]d2Fg`ClbD`Ci e$p,vsWu.NsYUW4J{,PG[{;QQhlOQa_8j&e6y/}Y*av2Jzw3hP\4cBO6^68lWr*,7Wrg_><c1-B}01_D$/O_~y4P,B,c~9*9@V7P- 5KS']n!/Mi/absV|@#aJe00GKmB4^R_XI7V$ !F AyUs9Ky=jL-ipF2E~=jlk?XI%zfx#$TFuq1u"2)sk&mqtoyJ yO Qb@Y0Ixa 2DfUFo:w#F;[ T}AxUA$:Y[I-uoB0+I`Yq@n&}n-f_)-u yXTwG"$'e(=% ]uj347W Vv'#N-e!'z\_{-669uoG@2)754FZM$4lY^w^ kY~ j~ ,*B,79r.;"0R=:3(&q/dw/9O,FnY6W `rb6_tpA%(p` U+7kN@.+,3)mE,o^}n DqpOY q'):@ Y(_dU fV@G[\ lCT;2bgdBik TEAZxp g:d[%/}`isU^>Pg) !wt0"_X::0|YhA,}n]#fl}&\2?C(T6tB pap/T4xXTNlMA Ni@A_"hPA3?[#S]Vbr9y7v3 dBG%tE:+g<\WFE ->^IRcNo;4X&$=/'G?kdRpZy1%_Ku_#j1yA $r`XIKhb0O1>n2[^ TET9[+a[+7jw[(%H $C^u'B 7P^r/{nIN\I[sKGwq[(n+;HB8 t" w4Ka9o]c[!?}=8p}M plr3+%tG2T[%EW7 )k]=vFZ/;&HI@A=ehz&s;zu8ssK Qh Z&XUjq.q, RYIN,ne .LN7_)w 0!9Dq`+=MBA v WPP?-"%$Y[.}!uz\a@D KM"f#X&rtU?Kb5, "'0<{XIhy37tzOrgf?PnB2u1'eb*Q0zY1}x1Hr:~X 8>pU A=oG`)zArOj >W_6YXAy5/l7I_sk0I>/-9l` ZmSMg 6WWC`frET 6q&6Pp|Zkf@`2bn: 3|_#&=L UY~nm]:s*co BkpLT_7frd0TVL(avwl !*aMHNe aTN5'p ?B<(}Nd^1qOqy[y0{Y 8B.$x|.ZpBrVFrNTkpNQ8W).Tmy;E_;9> w[8e,,T3~c2|qnS;mT{Na1[l6%^qfiRVZ^1W*['*9gN' IXBAc& uX,!\G#kg|y/[3#S CZh"LU.R+jy5?GO ':?R5!Zm0HIHCp5(gcS\Qiq)FqD$B,  6_l*+NtR:zoIdvQ6b,AdXP9 6Qa*+fSBd$%QcKEs)ZdZ='Q#(ftCddwx~3<DfPvj8kC"|j'!P\WM[;1x# C&x7V0`8#mG3!31 WqU+DVn;?+u!~RFO C@;7,9=MLg`'BINARY',' type_ascii_str = %   MGFTP023.G= I)[MGFTP.SOURCE]COPY_DIR_FTP_SUPPORT.B32;18M  IF (.status) THEN BEGIN !A ! Here, the destination file contains the remote host name,0 ! so we're doing a PUT to the remote node. !4 LIB$SYS_FAO (%ASCID'PUT!AS!AS !AS !AS', 0, str,- (IF .log THEN log_qual_str ELSE null_str), !6 ! By default, let MGFTP determine ASCII or BINARY.1 ! /ASCII is the default on COPY/FTP, so don't6 ! specify /TYPE=ASCII unless /ASCII was explicitly3 ! given on the command line. Likewise, specify3 ! /TYPE=IMAGE if /BINARY was given. If neither% ! was given, don't specify /TYPE. !2 (IF (CLI$PRESENT (ascii_str) EQLU CLI$_PRESENT) THEN type_ascii_str& ELSE IF (CLI$PRESENT (binary_str))- THEN type_binary_str ELSE null_str), fromstr, ffile); END ELSE !> ! Here, neither spec was a remote spec, so return error. !! RETURN (FTP$_COPFTPNOLOCAL); END; !' ! Need to handle these qualifiers. !2 ! As of V2.2, /FDL is not supported by MGFTP. !. ! qualifier ASCII, nonnegatable, default& ! qualifier BINARY, nonnegatable$ ! qualifier ANONYMOUS, default# ! qualifier FDL, nonnegatable ! qualifier LOG) ! qualifier NOSTRUVMS, nonnegatable ! qualifier VERBOSE !  !H ! If /FDL was given, tell user we don't support it and continue on. ! IF (CLI$PRESENT (fdl_str)) THEN@ SIGNAL (FTP$_IGNORFDL); !This is an INFORMATIONAL message onlyJ ! If /ANONYMOUS is there and no username was given, supply /ANONYMOUS. !F IF (CLI$PRESENT (anonymous_str)) AND (.user [DSC$W_LENGTH] EQLU 0) THEN, STR$APPEND (ftp_quals, anonymous_qual_str); !+ ! If /NOSTRUVMS, add /NOVMS_STRUCTURE. !( IF (CLI$PRESENT (%ASCID'NOSTRUVMS')) THEN2 STR$APPEND (ftp_quals, %ASCID'/NOVMS_STRUCTURE'); !G ! Because MGFTP is normally verbose, make it /QUIET/NOREPLY unless ! /VERBOSE is given. !+ status = CLI$PRESENT (%ASCID'VERBOSE');@ IF (.status EQLU CLI$_ABSENT) OR (.status EQLU CLI$_NEGATED) THEN0 STR$APPEND (ftp_quals, %ASCID'/QUIET/NOREPLY'); !% ! If there's a username, add it. !$ IF (.user [DSC$W_LENGTH] NEQU 0) THEN= STR$CONCAT (user, username_qual_str, user, doublequote_str); !% ! If there's a password, add it. !$ IF (.pass [DSC$W_LENGTH] NEQU 0) THEN= STR$CONCAT (pass, password_qual_str, pass, doublequote_str); !? ! Now build the final MG FTP command line to be re-parsed. !? status = LIB$SYS_FAO (%ASCID'FTP!AS !AS!AS!AS !AS', 0, cmd,$ ftp_quals, node, user, pass, str); STR$FREE1_DX (str); STR$FREE1_DX (fromstr); STR$FREE1_DX (tostr); STR$FREE1_DX (node); STR$FREE1_DX (user); STR$FREE1_DX (pass); STR$FREE1_DX (ffile); STR$FREE1_DX (ftp_quals); RETURN (.status);END; )GLOBAL ROUTINE build_dir_string (cmd_a) =BEGIN!+! Function: BUILD_DIR_STRING!! Functional description:!@! This routine is called to check the DIR/FTP command qualifiers?! and build a new MGFTP command line that will be parsed by theD! caller. Instead of providing internal CLD support for the DIR/FTPB! command, we just make a new command line that makes it look like"! the user invoked MGFTP directly.!! Input arguments:!7! cmd_a - Address of dynamic descriptor to receive the! MGFTP command line. ! Returns:!! SS$_NORMAL - Normal success9! FTP$_DIRFTPNOHOST - Error: no remote host was specified!!- BIND cmd = .cmd_a : $BBLOCK; LOCAL str : $BBLOCK [DSC$K_S_BLN]," fromstr : $BBLOCK [DSC$K_S_BLN], node : $BBLOCK [DSC$K_S_BLN], user : $BBLOCK [DSC$K_S_BLN], pass : $BBLOCK [DSC$K_S_BLN],# ftp_quals : $BBLOCK [DSC$K_S_BLN], ffile : $BBLOCK [DSC$K_S_BLN], full, status; $INIT_DYNDESC (str); $INIT_DYNDESC (fromstr); $INIT_DYNDESC (node); $INIT_DYNDESC (user); $INIT_DYNDESC (pass); $INIT_DYNDESC (ffile); $INIT_DYNDESC (ftp_quals);- status = CLI$GET_VALUE (p1_str, fromstr);4 full = CLI$PRESENT(%ASCID'FULL') AND SS$_NORMAL;? status = parse_nodespec (fromstr, node, user, pass, ffile); IF (.status) THEN BEGIN+ LIB$SYS_FAO (%ASCID'DIR!AS!AS!AS', 0, str,/ (IF .full THEN null_str ELSE %ASCID'/BRIEF'),A (IF .ffile [DSC$W_LENGTH] EQLU 0 THEN null_str ELSE blank_str), ffile); END ELSE !6 ! Here, spec was not a remote spec, so return error. ! RETURN (FTP$_DIRFTPNOHOST);F IF (CLI$PRESENT (anonymous_str)) AND (.user [DSC$W_LENGTH] EQLU 0) THEN, STR$APPEND (ftp_quals, anonymous_qual_str);$ IF (.user [DSC$W_LENGTH] NEQU 0) THEN= STR$CONCAT (user, username_qual_str, user, doublequote_str);$ IF (.pass [DSC$W_LENGTH] NEQU 0) THEN= STR$CONCAT (pass, password_qual_str, pass, doublequote_str);M status = LIB$SYS_FAO (%ASCID'FTP/QUIET/NOREPLY!AS !AS!AS!AS !AS', 0, cmd,$ ftp_quals, node, user, pass, str); STR$FREE1_DX (str); STR$FREE1_DX (fromstr); STR$FREE1_DX (node); STR$FREE1_DX (user); STR$FREE1_DX (pass); STR$FREE1_DX (ffile); STR$FREE1_DX (ftp_quals); RETURN (.status);END; %IF %VARIANT%THENROUTINE main =BEGIN LOCAL node : $BBLOCK [DSC$K_S_BLN], user : $BBLOCK [DSC$K_S_BLN], pass : $BBLOCK [DSC$K_S_BLN], rest : $BBLOCK [DSC$K_S_BLN], test : $BBLOCK [DSC$K_S_BLN], status; $INIT_DYNDESC (test); $INIT_DYNDESC (node); $INIT_DYNDESC (user); $INIT_DYNDESC (pass); $INIT_DYNDESC (rest);A STR$COPY_DX (test, %ASCID'ALPHA.WKU.EDU"goathunter test"::');: WHILE (LIB$GET_COMMAND (test, %ASCID'Node spec: ')) DO BEGIN8 status = parse_nodespec (test, node, user, pass, rest); IF (.status) THEN BEGINH LIB$SYS_FAO (%ASCID'Node: "!AS" User: "!AS" Pass: "!AS"', 0, test, node, user, pass); LIB$PUT_OUTPUT (test);) LIB$SYS_FAO (%ASCID'Rest: "!AS"', 0, test, rest); LIB$PUT_OUTPUT (test); END ELSE- LIB$PUT_OUTPUT (%ASCID'Parsing error!'); END;, RETURN (.status); !Set success statusEND; !End of routine%FIEND !End of module BEGINELUDOM !End of module*[MGFTP.SOURCE]DIR.B32;46+,{.H/ 4LHF-I0123KPWOG56V4]'7G4]'89GHJ ! MadGoat FTP client and server!?! Authors: Chad Wilson, Dale Moore, Tod Shannon, Bruce Miller,,! Marc Shannon, Henry Miller, John Clement,1! Matt Madison, Darrell Burkhead, Hunter Goatley!6! Copyright 1986, 1992, Carnegie Mellon University.B! Copyright 1994, 1998, MadGoat Software. All rights reserved.!?! Permission is granted for not-for-profit redistribution,?! provided all source and object code remain unchanged from?! the original distribution, and that al   MGFTP023.G{I[MGFTP.SOURCE]DIR.B32;46LHl copyright notices! remain intact.!MODULE dir( ADDRESSING_MODE( EXTERNAL = LONG_RELATIVE, NONEXTERNAL = LONG_RELATIVE),$ LIST(ASSEMBLY, NOBINARY, NOEXPAND), IDENT = 'V2.3') =BEGIN!++! Description:!7! Routines for manipulating directories for FTP server.!<! No matter how tempting, we can't use spawn, cause we ain't5! necessarily got any CLI, and LIB$SPAWN needs a CLI.!/! Written_By: Dale Moore 24-MAR-1986 CMU-CS/RI!! Modifications:!)! V2.3 Hunter Goatley 26-FEB-1998 11:25=! Modify set_current_dir() to not call translate_directory()-! if it's already been called by the caller.!)! V2.2 Hunter Goatley 3-JAN-1995 09:52<! Added support for "~username" to get to default directory! for that user.!%! Hunter Goatley 5-AUG-1996 23:05?! Finish support for "~username", including anonymous support.!%! Hunter Goatley 15-AUG-1996 10:109! Change translate_directory() so that "/" is translated5! to "SYS$DISK:[000000]" instead of to "SYS$LOGIN:".!*! V2.1 Darrell Burkhead 28-JUL-1994 13:25&! Recognize . as a version delimeter.!*! V2.0 Darrell Burkhead 31-JAN-1994 11:09;! Modified translate_directory to check for logical names.8! For example, CWD SYS$LOGIN would try to switch to the6! [.SYS$LOGIN] subdirectory of the current directory.?! translate_directory now checks whether [.name] exists before>! returning it. If the directory doesn't exist, then name is9! is assumed to be a logical name and name: is returned.!)! V1.0 Hunter Goatley 24-SEP-1993 13:582! Modified Set_Current_Dir to define SYS$DISK via5! LIB$SET_LOGICAL so it's a supervisor-mode logical.*! Needed so that a SPAWN works correctly.!--!LIBRARY 'SYS$LIBRARY:STARLET';LIBRARY 'SYS$LIBRARY:LIB';LIBRARY 'NETAUX';LIBRARY 'TEXT'; COMPILETIME debug = 0;B%IF debug %THEN %MESSAGE('DEBUG mode is enabled in DIR.B32!') %FI; BIND, lnm$dcl_logical = %ASCID'LNM$DCL_LOGICAL',& lnm$file_dev = %ASCID'LNM$FILE_DEV',/ lnm$process_table = %ASCID'LNM$PROCESS_TABLE',< wildcards_str = %ASCID'$%_______________________________',< validunixchar_str = %ASCID'.?~`!@#^&()+={}[]<>:;"''|\,/ ',9 alphabet_lower_str = %ASCID'abcdefghijklmnopqrstuvwxyz',4 alphabet_str = %ASCID'ABCDEFGHIJKLMNOPQRSTUVWXYZ', bracketdot_str = %ASCID'[.', dash_str = %ASCID'-', period_str = %ASCID'.', dotdot_str = %ASCID'..', dotdotslash_str = %ASCID'../', slash_str = %ASCID'/', colon_str = %ASCID':', semicolon_str = %ASCID';', lbracket_str = %ASCID'[', updir_str = %ASCID'[-]', rbracket_str = %ASCID']', sys$disk = %ASCID'SYS$DISK',! sys$login = %ASCID'SYS$LOGIN:', null_str = %ASCID''; -ROUTINE logical_name(in_name_a, out_name_a) = BEGIN BIND" in_name = .in_name_a : $BBLOCK,# out_name = .out_name_a : $BBLOCK; EXTERNAL ROUTINE- STR$COPY_R : BLISS ADDRESSING_MODE(GENERAL); LOCAL% item_list : $ITMLST_DECL(ITEMS = 4), attributes : $BBLOCK[4], max_index : INITIAL(0)," trans_buffer : VECTOR[512, BYTE], trans_length : WORD UNSIGNED, status;> IF .in_name[DSC$W_LENGTH] EQL 0 THEN RETURN(SS$_NOLOGNAM);$ $ITMLST_INIT(ITMLST = item_list,1 (ITMCOD = LNM$_ATTRIBUTES, BUFADR = attributes),/ (ITMCOD = LNM$_MAX_INDEX, BUFADR = max_index),. (ITMCOD = LNM$_STRING, BUFADR = trans_buffer,> BUFSIZ = %ALLOCATION(trans_buffer), RETLEN = trans_length)); status = $TRNLNM( TABNAM = lnm$file_dev, LOGNAM = in_name, ITMLST = item_list);5 IF .status EQL SS$_NOLOGNAM THEN RETURN(.status);2 IF .max_index NEQ 0 THEN RETURN(SS$_NOLOGNAM);> IF .attributes[LNM$V_CONCEALED] THEN RETURN(SS$_NOLOGNAM);> status = STR$COPY_R(out_name, trans_length, trans_buffer);( IF NOT .status THEN SIGNAL(.status); SS$_NORMAL END; ROUTINE dir_exists( dir_a ) =!G! Tests whether a given directory spec corresponds to a real directory.B! Used to decide whether CWD name meands CWD [.name] or CWD name:.! BEGIN BIND dir = .dir_a : $BBLOCK; LOCAL status, ename : $BBLOCK[NAM$C_MAXRSS], parse_nam : $NAM( ESA = ename, ESS = %ALLOCATION(ename)),$ parse_fab : $FAB( NAM = parse_nam);/ parse_fab[FAB$L_FNA] = .dir[DSC$A_POINTER];. parse_fab[FAB$B_FNS] = .dir[DSC$W_LENGTH];% status = $PARSE(FAB = parse_fab);< RETURN NOT (.status EQL RMS$_DNF); !Ignore other errors END; :GLOBAL ROUTINE translate_directory_to_unix (out_a, in_a) =BEGIN!7! Converts a VMS directory string to UNIX-style format..! E.g. USER:[HUNTER.GIF] -> /user/hunter/gif/! BIND in = .in_a : $BBLOCK, out = .out_a : $BBLOCK; EXTERNAL ROUTINE- STR$COPY_R : BLISS ADDRESSING_MODE(GENERAL); LOCAL status, sptr : REF $BBLOCK, dptr : REF $BBLOCK, work : $BBLOCK[NAM$C_MAXRSS]; sptr = .in [DSC$A_POINTER]; dptr = work; CH$WCHAR_A(%C'/', dptr);* INCR i FROM 1 TO .in [DSC$W_LENGTH] DO BEGIN LOCAL ch; ch = CH$RCHAR_A(sptr); IF (.ch EQLU %C'.') OR+ (.ch EQLU %C'[') OR (.ch EQLU %C']') OR( (.ch EQLU %C'<') OR (.ch EQLU %C'>') THEN CH$WCHAR_A (%C'/', dptr) ELSE IF (.ch NEQU %C':') THEN5 CH$WCHAR_A ((IF (.ch GEQU %C'A' AND .ch LEQU %C'Z')+ THEN .ch + %X'20' ELSE .ch), dptr); END;5 dptr = .dptr - work; !Get final length of string= STR$COPY_R (out, dptr, work); !Copy it to caller's buffer SS$_NORMAL END; IGLOBAL ROUTINE translate_directory( out_desc_a, in_desc_a, anon, rdirq) =!+! This translates directory specifications:'! It converts U*X conventions to VMS JC! BEGIN BIND" in_desc = .in_desc_a : $BBLOCK,# out_desc = .out_desc_a : $BBLOCK; EXTERNAL ROUTINE. STR$COMPARE : BLISS ADDRESSING_MODE(GENERAL),- STR$APPEND : BLISS ADDRESSING_MODE(GENERAL),- STR$CONCAT : BLISS ADDRESSING_MODE(GENERAL),+ STR$LEFT : BLISS ADDRESSING_MODE(GENERAL),/ STR$POSITION : BLISS ADDRESSING_MODE(GENERAL),, STR$RIGHT : BLISS ADDRESSING_MODE(GENERAL),0 STR$TRANSLATE : BLISS ADDRESSING_MODE(GENERAL),- STR$UPCASE : BLISS ADDRESSING_MODE(GENERAL),0 STR$COPY_DX : BLISS ADDRESSING_MODE(GENERAL),/ STR$FREE1_DX : BLISS ADDRESSING_MODE(GENERAL), toggle_priv, add_to_rdirq; LOCAL) temp_desc : $BBLOCK[DSC$K_S_BLN],* temp1_desc : $BBLOCK[DSC$K_S_BLN], status; $INIT_DYNDESC(temp_desc); $INIT_DYNDESC(temp1_desc);:! First, check for angle-bracket directory delimeters.../ status = STR$POSITION(in_desc, %ASCID '<'); IF(.status GTR 0) THEN BEGIN status = STR$TRANSLATE( in_desc, ! Dst in_desc, ! Src %ASCID '[]', ! trans %ASCID '<>'); ! match% IF NOT .status THEN SIGNAL(.status); END ; ! ... and all that other stuff . status = STR$POSITION(in_desc, slash_str); 5 IF (STR$POSITION(IN_Desc, lbracket_str) GTR 0) OR- (STR$POSITION(IN_Desc, colon_str) GTR 0)' THEN STR$COPY_DX(out_desc, IN_Desc)5 ELSE IF STR$COMPARE( IN_Desc , dotdot_str ) EQL 0) THEN STR$COPY_DX(out_desc, updir_str)9 ELSE IF (STR$COMPARE( IN_Desc , slash_str ) EQL 0) OR% (.IN_Desc[DSC$W_LENGTH] EQL 0)9 THEN STR$COPY_DX(out_desc, %ASCID'SYS$DISK:[000000]') ELSE IF (.status EQL 0) AND4 (CH$RCHAR(.in_desc [DSC$A_POINTER]) NEQU %C'~') THEN BEGIN= STR$CONCAT(out_desc, bracketdot_str, in_desc, rbracket_str); !A ! If [.in_desc] isn't a directory and in_desc is a logical name,@ ! then append a : so in_desc will be treated as a logical  MGFTP023.G{I[MGFTP.SOURCE]DIR.B32;46LH8U name. ! IF NOT dir_exists(out_desc) THEN BEGIN !( ! Logical names are case-sensitive. !$ STR$UPCASE(temp_desc, in_desc);* IF $TRNLNM( TABNAM = lnm$dcl_logical, LOGNAM = temp_desc)5 THEN STR$CONCAT(out_desc, temp_desc, colon_str); STR$FREE1_DX(temp_desc); END; END ELSE BEGIN !2 ! Here, it's a UNIX-style string, so convert it. !# STR$COPY_DX( temp_desc, IN_Desc );/ IF .status EQL 1 !If first character was "/" THEN BEGIN/ STR$RIGHT( temp_desc, temp_desc, %REF(2));) STR$COPY_DX( out_desc, lbracket_str) END ELSE6 IF STR$POSITION(temp_desc, dotdotslash_str) EQL 1 THEN BEGIN, STR$RIGHT( temp_desc, temp_desc, %REF(4));& STR$COPY_DX( out_desc, %ASCID '[-.') END ELSE/ IF STR$POSITION(temp_desc, %ASCID './') EQL 1 THEN BEGIN0 STR$RIGHT( temp_desc, temp_desc, %REF(3));, STR$COPY_DX( out_desc, bracketdot_str) END. ELSE STR$COPY_DX( out_desc, bracketdot_str); !> ! Special case: check for "~user" and translate accordingly. !5 IF (CH$RCHAR(.temp_desc [DSC$A_POINTER]) EQLU %C'~') THEN BEGIN BUILTIN ACTUALCOUNT; EXTERNAL ROUTINE. STR$COPY_R : BLISS ADDRESSING_MODE(GENERAL); EXTERNAL1 exec_mode, lnm$system_table; !Defined in FTP_IN LOCAL- defdir : VOLATILE $BBLOCK [NAM$C_MAXRSS],- defdev : VOLATILE $BBLOCK [NAM$C_MAXRSS], devlen, dirlen,( uai_itmlst : $ITMLST_DECL (ITEMS=2), status,% username : $BBLOCK [DSC$K_S_BLN],) aftp_dirbuf : $BBLOCK [NAM$C_MAXRSS],% aftp_dir : $BBLOCK [DSC$K_S_BLN],& work_desc : $BBLOCK [DSC$K_S_BLN]; $INIT_DYNDESC (aftp_dir); %IF debug7 %THEN print('Handle ~ Temp=(''!AS'')', temp_desc); %FI" aftp_dir [DSC$W_LENGTH] = 0;. aftp_dir [DSC$B_DTYPE] = DSC$K_DTYPE_T;. aftp_dir [DSC$B_CLASS] = DSC$K_CLASS_S;, aftp_dir [DSC$A_POINTER] = aftp_dirbuf;J IF (ACTUALCOUNT() GTRU 2) AND (.anon) !Is it an ANONYMOUS connection? THEN BEGIN LOCAL2 lnm_itmlst : $ITMLST_DECL (ITEMS=1), lnmlen; !; ! See if the system manager allows "~user" for ANONYMOUSA ! connections by seeing if a logical is defined that specifies< ! the name of the user AFTP subdirectory. If the logical; ! is not defined, then it is assumed that ~user does not ! work for anonymous users. !$ $ITMLST_INIT (ITMLST = lnm_itmlst,/ (ITMCOD = LNM$_STRING, BUFADR = aftp_dirbuf,: BUFSIZ = %ALLOCATION (aftp_dirbuf), RETLEN = lnmlen));. status = $TRNLNM (TABNAM = lnm$system_table, ACMODE = exec_mode,1 LOGNAM = %ASCID'MADGOAT_FTP_TILDE_ANONDIR', ITMLST = lnm_itmlst);( IF NOT(.status) THEN RETURN (.status);% aftp_dir [DSC$W_LENGTH] = .lnmlen; %IF debug7 %THEN print('Handle ~ aftp_dir=(''!AS'')', aftp_dir); %FI END;' $ITMLST_INIT (ITMLST = uai_itmlst,6 (ITMCOD = UAI$_DEFDEV, BUFSIZ = %ALLOCATION(defdev), BUFADR = defdev),6 (ITMCOD = UAI$_DEFDIR, BUFSIZ = %ALLOCATION(defdir), BUFADR = defdir));F work_desc [DSC$B_DTYPE] = username [DSC$B_DTYPE] = DSC$K_DTYPE_T;F work_desc [DSC$B_CLASS] = username [DSC$B_CLASS] = DSC$K_CLASS_S;? username [DSC$A_POINTER] = .temp_desc [DSC$A_POINTER] + 1; username [DSC$W_LENGTH] =; (IF (dirlen = STR$POSITION (temp_desc, slash_str)) EQLU 0' THEN (.temp_desc [DSC$W_LENGTH] - 1) ELSE (.dirlen - 2)); !; ! If there's just a "/" at the end, don't include "." !0 IF (.dirlen EQLU .temp_desc [DSC$W_LENGTH]) THEN dirlen = 0; %IF debug= %THEN print('Handle ~ Temp=(''!AS''), dirlen=(''!UL'')', temp_desc, .dirlen); %FI toggle_priv (1, 0, 0);? status = $GETUAI (USRNAM = username, ITMLST = uai_itmlst); toggle_priv (0, 0, 0);) IF NOT(.status) THEN RETURN .status;1 work_desc [DSC$W_LENGTH] = CH$RCHAR(defdir);9 work_desc [DSC$A_POINTER] = defdir + 1; !Skip length' IF (CH$RCHAR(defdir+1) EQLU %C'<') THEN CH$WCHAR(%C'[',defdir+1); devlen = CH$RCHAR(defdev);F STR$COPY_R (out_desc, devlen, defdev+1); !Copy device to out_desc !5 ! Turn the "]" in to a "." in case it's needed. !@ CH$WCHAR(%C'.', CH$PLUS(defdir, .work_desc[DSC$W_LENGTH])); IF (.dirlen NEQU 0) THEN BEGIN dirlen = .dirlen + 1;+ STR$RIGHT (temp_desc, temp_desc, dirlen); END ELSE BEGIN != ! If this is not an anonymous connection, then don't count ! the "." in the length. !& IF (.aftp_dir [DSC$W_LENGTH] EQLU 0) THEN? work_desc [DSC$W_LENGTH] = .work_desc [DSC$W_LENGTH] - 1;$ STR$COPY_DX (temp_desc, null_str); END;& STR$APPEND (out_desc, work_desc); %IF debug: %THEN print('Handle ~ Temp=(''!AS'') Out=(''!AS'')', temp_desc, out_desc); %FI !B ! If this is for an ANONYMOUS connection, then tack the anon9 ! subdirectory name onto the user's home directory. !) IF (.aftp_dir [DSC$W_LENGTH] NEQU 0) THEN BEGIN% LOCAL tmp2 : $BBLOCK [DSC$K_S_BLN]; $INIT_DYNDESC (tmp2);" STR$APPEND (out_desc, aftp_dir);, STR$CONCAT (tmp2, out_desc, %ASCID'...]');. add_to_rdirq (.rdirq, tmp2); !Add to OK list STR$FREE1_DX (tmp2); IF (.dirlen NEQU 0) AND' (.temp_desc [DSC$W_LENGTH] NEQU 0) THEN BEGIN( STR$APPEND (out_desc, period_str); %IF debug& %THEN print('Handle ~ Added .'); %FI END; END; END; WHILE 1 DO BEGIN ! ! Look for a "/" !1 status = STR$POSITION(temp_desc, slash_str); %IF debug< %THEN print('Translate1 Temp=(''!AS'') OUt =(''!AS'')', temp_desc, out_desc); %FI( IF .status GTR 0 !A "/" was found THEN BEGIN !7 ! See if it's really "../"; if so, replace with "-",3 ! Otherwise, just copy the string up to the "/". !3 IF STR$POSITION(temp_desc, dotdotslash_str) EQL 1 THEN% STR$APPEND( out_desc, dash_str) ELSE BEGIN9 STR$LEFT(temp1_desc, temp_desc, %REF(.status -1 ));( STR$APPEND( out_desc, temp1_desc); END;6 STR$RIGHT( temp_desc, temp_desc, %REF(.status + 1)); %IF debug9 %THEN print('Translate2 Temp=(''!AS'') OUt =(''!AS'')', temp_desc, out_desc); %FI# IF .temp_desc[DSC$W_LENGTH] GTR 0) THEN STR$APPEND( out_desc, period_str); END ELSE BEGIN0 IF STR$COMPARE( temp_desc , dotdot_str ) EQL 0' THEN STR$APPEND( out_desc, dash_str )( ELSE IF .temp_desc[DSC$W_LENGTH] GTR 0) THEN STR$APPEND( out_desc, temp_desc ); %IF debug9 %THEN print('Translate3 Temp=(''!AS'') OUt =(''!AS'')', temp_desc, out_desc); %FI EXITLOOP; END; END;% STR$APPEND( out_desc, rbracket_str); %IF debug8 %THEN print('Translate4 Temp=(''!AS'') OUt =(''!AS'')', temp_desc, out_desc); %FI END;# STR$UPCASE(out_desc, out_desc); STR$FREE1_DX(temp_desc); STR$FREE1_DX(temp1_desc); SS$_NORMAL END; KGLOBAL ROUTINE translate_file( out_desc_a, in_desc_a, wild, anon, rdirq ) =!+! This translates directory specifications:'! It converts U*X conventions to VMS JC! BEGIN BIND" in_desc = .in_desc_a : $BBLOCK,# out_desc = .out_desc_a : $BBLOCK; EXTERNAL ROUTINE/ STR$APPEND : BLISS ADDRESSING_MODE(GENERAL),0 STR$COMPARE : BLISS ADDRESSING_MODE(GENERAL),/ STR$CONCAT : BLISS ADDRESSING_MODE(GENERAL),2 STR$COPY_DX : BLISS ADDRESSING_MODE(GENERAL),  MGFTP023.G{I[MGFTP.SOURCE]DIR.B32;46LH < STR$FIND_FIRST_NOT_IN_SET : BLISS ADDRESSING_MODE(GENERAL),- STR$LEFT : BLISS ADDRESSING_MODE(GENERAL),1 STR$POSITION : BLISS ADDRESSING_MODE(GENERAL),. STR$RIGHT : BLISS ADDRESSING_MODE(GENERAL),2 STR$TRANSLATE : BLISS ADDRESSING_MODE(GENERAL),/ STR$UPCASE : BLISS ADDRESSING_MODE(GENERAL),1 STR$FREE1_DX : BLISS ADDRESSING_MODE(GENERAL); LOCAL) directory : $BBLOCK[DSC$K_S_BLN] PRESET( [DSC$W_LENGTH] = 0,# [DSC$B_DTYPE] = DSC$K_DTYPE_T,# [DSC$B_CLASS] = DSC$K_CLASS_D,o [DSC$A_POINTER] = 0),% name : $BBLOCK[DSC$K_S_BLN] PRESET(T [DSC$W_LENGTH] = 0,# [DSC$B_DTYPE] = DSC$K_DTYPE_T, # [DSC$B_CLASS] = DSC$K_CLASS_D,r [DSC$A_POINTER] = 0),% type : $BBLOCK[DSC$K_S_BLN] PRESET(l [DSC$W_LENGTH] = 0,# [DSC$B_DTYPE] = DSC$K_DTYPE_T,l# [DSC$B_CLASS] = DSC$K_CLASS_D,  [DSC$A_POINTER] = 0),( version : $BBLOCK[DSC$K_S_BLN] PRESET( [DSC$W_LENGTH] = 0,# [DSC$B_DTYPE] = DSC$K_DTYPE_T,l# [DSC$B_CLASS] = DSC$K_CLASS_D,h [DSC$A_POINTER] = 0), got_type : INITIAL(0), got_version : INITIAL(0), i,L j : INITIAL(0),O status; !L) ! If ']' or ":" in string, assume VMSD !E5 IF (STR$POSITION(in_desc, rbracket_str) NEQ 0) ORo) (STR$POSITION(in_desc, colon_str) NEQ 0)  THEN BEGIN( status = STR$UPCASE(out_desc, in_desc); RETURN SS$_NORMAL;e END;l ! $ ! If '/' in string assume U*X??? !e( status = STR$UPCASE( name, in_desc);& i = STR$POSITION(name, slash_str); IF .i NEQ 01 THEN BEGIN ! ! Hunt for last "/" ! WHILE 1 DO BEGINt4 j = STR$POSITION(name, slash_str, %REF(.j +1)); IF .j EQL 0 THEN EXITLOOP ELSE i = .j;d END;r( STR$LEFT (directory, name, i); ! Dir- STR$RIGHT(name, name, %REF( .i +1)); ! nameAI translate_directory( directory, directory, .anon, .rdirq); ! Dir --> VMSo END; !++r ! Split file into name.typeC !--n( i = STR$POSITION( name, period_str); IF .i NEQ 0S THEN BEGIN got_type = 1;% STR$RIGHT( type, name, %REF(.i +1));2% STR$LEFT ( name, name, %REF(.i -1));e END ELSE BEGIN( i = STR$POSITION( name, semicolon_str); IF .i NEQ 0 THEN BEGINe& STR$RIGHT( type, name, %REF(.i));) STR$LEFT ( name, name, %REF(.i -1));c END;  END;L !++r" ! Split file into type;version !--e+ i = STR$POSITION( type, semicolon_str);b IF .i EQL 0i, THEN i = STR$POSITION(type, period_str); IF .i NEQ 0u THEN BEGIN( STR$RIGHT( version, type, %REF(.i +1)); !+ ! version must be max of 6 numbers, Is IT?e ! IF ((STR$FIND_FIRST_NOT_IN_SET( version, IF .wild THEN %ASCID '+-0123456789%*'( ELSE %ASCID '+-0123456789') NEQ 0) AND! (.version[DSC$W_LENGTH] NEQ 0)):) THEN STR$FREE1_DX( version ) ! Kill itR ELSE BEGIN 4 STR$LEFT ( type, type, %REF(.I -1)); ! Split it got_version = 1;E END;e END;b2 STR$LEFT(type, type, %REF(39)); ! Trim length; STR$TRANSLATE(type, type, ! Translate bad characters.D wildcards_str,b validunixchar_str);2 STR$LEFT(name, name, %REF(39)); ! Trim length; STR$TRANSLATE(name, name, ! Translate bad characters.< wildcards_str,a validunixchar_str);* STR$CONCAT( out_desc, directory, name,3 IF .got_type THEN period_str ELSE null_str, type,== IF .got_version THEN semicolon_str ELSE null_str, version);' ! DIR + FILE+type+Ver' IF NOT .wild+ THEN STR$TRANSLATE( out_desc, out_desc, %ASCID '___', %ASCID '*?%'); STR$FREE1_DX(version); STR$FREE1_DX(type);u STR$FREE1_DX(directory); STR$FREE1_DX(name); SS$_NORMAL END; ,,GLOBAL ROUTINE get_current_dir(dir_desc_a) =!++%! Functional Description:i!_3! RETURN the name of the current default directory.!_1! We must do this by translating the logical namem4! SYS$DISK and appending the results of SYS$SETDDIR.!-- BEGINM BIND# dir_desc = .dir_desc_a : $BBLOCK;T EXTERNAL ROUTINE. SYS$SETDDIR : BLISS ADDRESSING_MODE(GENERAL),- STR$APPEND : BLISS ADDRESSING_MODE(GENERAL);l LOCALD% current_dir_vec : VECTOR[512, BYTE],[/ current_dir_desc: $BBLOCK[DSC$K_S_BLN] PRESET(1 [DSC$W_LENGTH] = %ALLOCATION(current_dir_vec),M! [DSC$B_DTYPE] = DSC$K_DTYPE_T,! [DSC$B_CLASS] = DSC$K_CLASS_S, & [DSC$A_POINTER] = current_dir_vec), status;. status = logical_name(sys$disk, dir_desc);( IF NOT .status THEN SIGNAL(.status); status = SYS$SETDDIR(l 0,! current_dir_desc[DSC$W_LENGTH],i curr )ent_dir_desc);( IF NOT .status THEN SIGNAL(.status); status = STR$APPEND( dir_desc,( current_dir_desc);( IF NOT .status THEN SIGNAL(.status);  SS$_NORMAL END; R?GLOBAL ROUTINE set_current_dir(new_dir_a, already_translated) =s!++ ! Functional Description:_!M(! Set the new current default directory.!-- BEGINt BIND # new_dir = .new_dir_a : $BBLOCK;d BUILTIN ACTUALCOUNT;w EXTERNAL ROUTINE2 LIB$SET_LOGICAL : BLISS ADDRESSING_MODE(GENERAL),. SYS$SETDDIR : BLISS ADDRESSING_MODE(GENERAL),1 STR$COPY_R : BLISS ADDRESSING_MODE(GENERAL),A- STR$APPEND : BLISS ADDRESSING_MODE(GENERAL),,0 STR$COPY_DX : BLISS ADDRESSING_MODE(GENERAL),/ STR$FREE1_DX : BLISS ADDRESSING_MODE(GENERAL);s LOCAL_ fab : $FAB_DECL, nam : $NAM_DECL,s& parsed_dspec : VECTOR[255, BYTE],% new_dev_desc : $BBLOCK[DSC$K_S_BLN],N% new_dir_desc : $BBLOCK[DSC$K_S_BLN],o) temp_desc : $BBLOCK[DSC$K_S_BLN],o) new_spec : $BBLOCK[DSC$K_S_BLN], 0 prev_ddesc : $BBLOCK[DSC$K_S_BLN] PRESET(? [DSC$W_LENGTH] = %ALLOCATION(parsed_dspec),B2 [DSC$B_DTYPE] = DSC$K_DTYPE_T,2 [DSC$B_CLASS] = DSC$K_CLASS_S,4 [DSC$A_POINTER] = parsed_dspec), prev_dlen : WORD,  flds : $BBLOCK[4], status; $INIT_DYNDESC(temp_desc);r $INIT_DYNDESC(new_spec); $INIT_DYNDESC(new_dev_desc); $INIT_DYNDESC(new_dir_desc);9 IF (ACTUALCOUNT() EQLU 1) OR NOT(.already_translated)) THEN' translate_directory(new_spec, new_dir)E ELSE! STR$COPY_DX (new_spec, new_dir); %IF debugCH %THEN print('Set current_Dir(''!AS'')(''!AS'')', new_dir, new_spec); %FIHI status = $FILESCAN(SRCSTR=new_spec, VALUELST=%REF(0), FLDFLAGS=flds);f IF NOT .status THEN BEGIN STR$FREE1_DX(new_spec); RETURN(.status); END;_B IF .flds[0,0,32,0] EQLU FSCN$M_NAME ! unadorned logical name? THEN BEGIN% STR$APPEND(new_spec, colon_str);i: status = $FILESCAN(SRCSTR=new_spec, VALUELST=%REF(0), FLDFLAGS=flds); IF NOT .statusi THEN BEGINB STR$FREE1_DX(new_spec); RETURN(.status);U END;C END;:8 IF NOT(.flds[FSCN$V_NODE] OR .flds[FSCN$V_DEVICE] OR7 .flds[FSCN$V_ROOT] OR .flds[FSCN$V_DIRECTORY])D0 OR .flds[FSCN$V_NAME] OR .flds[FSCN$V_TYPE] OR .flds[FSCN$V_VERSION]  THEN BEGIN STR$FREE1_DX(new_spec); RETURN(RMS$_DIR); END;RH $NAM_INIT(NAM=nam, ESA=parsed_dspec, ESS=%ALLOCATION(parsed_dspec));4 $FAB_INIT(FAB=fab, FNA=.new_spec[DSC$A_POINTER],+ FNS=.new_spec[DSC$W_LENGTH], NAM=nam);G status = $PARSE(FAB=fab); STR$FREE1_DX(new_spec);( IF NOT .status THEN RETURN(.status);E STR$COPY_R(new_dir_DESC, %REF(.nam[NAM$B_DIR]), .nam[NAM$L_DIR]);D IF .nam[NAM$B_NODE] GTR 0D THEN BEGIN $INIT_DYNDESC(temp_desc);H STR$COPY_R(new_dev_desc, %REF(.nam[NAM$B_NODE]), .nam[NAM$L_NODE]  MGFTP023.G{I[MGFTP.SOURCE]DIR.B32;46LHY/);C STR$COPY_R(temp_desc, %REF(.nam[NAM$B_DEV]), .nam[NAM$L_DEV]);T) STR$APPEND(new_dev_desc, temp_desc);r STR$FREE1_DX(temp_desc); ENDJ ELSE STR$COPY_R(new_dev_desc, %REF(.nam[NAM$B_DEV]), .nam[NAM$L_DEV]);> status = SYS$SETDDIR(new_dir_desc, prev_dlen, prev_ddesc);( IF NOT .status THEN RETURN(.status);) IF .new_dev_desc[DSC$W_LENGTH] NEQU 0T THEN BEGIN1 status = LIB$SET_LOGICAL(sys$disk, new_dev_desc,s lnm$process_table); IF NOT .status_ THEN BEGIN_/ prev_ddesc[DSC$W_LENGTH] = .prev_dlen;r' SYS$SETDDIR(prev_ddesc, 0, 0);  RETURN(.status); END;e END;W STR$FREE1_DX(new_dev_desc);_ STR$FREE1_DX(new_dir_desc);0 SS$_NORMAL END; L9GLOBAL ROUTINE create_directory(dir_name_a, out_name_a) =~!++ ! Functional Description:u!e-! Create a directory with the name specified.!!--I BEGIN] BIND# out_name = .out_name_a : $BBLOCK,e# dir_name = .dir_name_a : $BBLOCK;l EXTERNAL ROUTINE.1 STR$COPY_DX : BLISS ADDRESSING_MODE(GENERAL),/ STR$FREE1_DX : BLISS ADDRESSING_MODE(GENERAL),e1 LIB$CREATE_DIR : BLISS ADDRESSING_MODE(GENERAL);c LOCAL ) new_spec : $BBLOCK[DSC$K_S_BLN],A status; $INIT_DYNDESC(new_spec);- translate_directory(new_spec, dir_name );e$ STR$COPY_DX(out_name, new_spec); %IF debugeB %THEN print('create_Dir ''!AS'' ''!AS''', dir_name, new_spec); %FI_& status = LIB$CREATE_DIR(new_spec); STR$FREE1_DX(new_spec);B( IF NOT .status THEN SIGNAL(.status); .status  END; 9GLOBAL ROUTINE delete_directory(dir_name_a, out_name_a) =I!++t! Functional Description:E!1 ! Delete the named directory. JC!--m BEGINp BIND# out_name = .out_name_a : $BBLOCK,I# dir_name = .dir_name_a : $BBLOCK;R EXTERNAL ROUTINE2 LIB$DELETE_FILE : BLISS ADDRESSING_MODE(GENERAL),. STR$COPY_DX : BLISS ADDRESSING_MODE(GENERAL),+ STR$LEFT : BLISS ADDRESSING_MODE(GENERAL),, STR$RIGHT : BLISS ADDRESSING_MODE(GENERAL),- STR$APPEND : BLISS ADDRESSING_MODE(GENERAL),n/ STR$POSITION : BLISS ADDRESSING_MODE(GENERAL),_/ STR$FREE1_DX : BLISS ADDRESSING_MODE(GENERAL);B LOCALB rab : $BBLOCK[RAB$C_BLN],T fab : $BBLOCK[FAB$C_BLN],:! xabpro : $BBLOCK[XAB$C_PROLEN], position,* temp_spec : $BBLOCK[DSC$K_S_BLN],) new_spec : $BBLOCK[DSC$K_S_BLN],  status; $INIT_DYNDESC(temp_spec);T $INIT_DYNDESC(new_spec);- translate_directory(new_spec, dir_name );C$ STR$COPY_DX(out_name, new_spec); 5 position = STR$POSITION( new_spec, rbracket_str);C IF .position GTR 0 THEN BEGIN4 STR$LEFT( new_spec, new_spec, %REF(.position - 1)); status = 0; WHILE 1 DO BEGIN D position = STR$position(new_spec, period_str, %REF(.status+1)); IF .position EQL 0D THEN BEGIN; IF .status EQL 0. THEN STR$RIGHT( new_spec, new_spec, %REF(2)) ELSE IF .status EQL 2_. THEN STR$RIGHT( new_spec, new_spec, %REF(3)) ELSE BEGIN8 STR$RIGHT(temp_spec, new_spec, %REF(.status + 1));6 STR$LEFT(new_spec, new_spec, %REF(.status - 1));) STR$APPEND(new_spec, rbracket_str); & STR$APPEND(new_spec, temp_spec); END; U EXITLOOP;e END; status = .position; END; ' STR$APPEND(new_spec, %ASCID '.DIR;1');P END;e %IF debuggB %THEN print('delete_Dir ''!AS'' ''!AS''', dir_name, new_spec); %FI $XABPRO_INIT( xab = xabpro); $FAB_INIT( FAB = fab, FAC = ,U" FNA = .new_spec[DSC$A_POINTER],! FNS = .new_spec[DSC$W_LENGTH],l XAB = xabpro);= $RAB_INIT( RAB = rab,_ FAB = fab); status = $OPEN(FAB = fab); IF .status THEN BEGIN IF $CONNECT(RAB = RAB)i THEN BEGINF# status = $TRUNCATE(RAB = rab);9 xabpro[XAB$W_PRO] = .xabpro[XAB$W_PRO] AND %X'FF0F';T END;H status = $CLOSE(FAB = fab); END;) IF .status, THEN status = LIB$DELETE_FILE(new_spec); STR$FREE1_DX(temp_spec); STR$FREE1_DX(new_spec);F( IF NOT .status THEN SIGNAL(.status); SS$_NORMAL END; B8GLOBAL ROUTINE set_protection(file_name_a, protection) =!++D! Functional Description:;! ! Delete the named directory. JC!--D BEGIN  BIND% file_name = .file_name_a : $BBLOCK; LOCAL[ rab : $BBLOCK[RAB$C_BLN],e fab : $BBLOCK[FAB$C_BLN], ! xabpro : $BBLOCK[XAB$C_PROLEN],s status; %IF debug I %THEN print('set_protection ''!AS'' ''!XL''', file_name, protection);! %FIe $XABPRO_INIT(xab = xabpro);l $FAB_INIT( FAB = fab,i FAC = ," FNA = .file_name[DSC$A_POINTER],! FNS = .file_name[DSC$W_LENGTH],i XAB = XABPRO); $RAB_INIT( RAB = RAB, FAB = FAB);  status = $OPEN(FAB = fab); IF .status THEN BEGIN IF $CONNECT(RAB = rab)e THEN BEGINi# status = $TRUNCATE(RAB = rab);)9 xabpro[XAB$W_PRO] =(.xabpro[XAB$W_PRO] AND %x'000F')_ OR(.protection AND %X'FFD0'); END;  status = $CLOSE(FAB = fab); END; .status END; C4GLOBAL ROUTINE directory_list_text(text_a, path_a) =!++'! Functional Description: !H=! Get a directory listing, suitable for the ftp list command,)1! and put the results in the Text data structure.t!--" BEGIN" BIND text = .text_a : $BBLOCK, path = .path_a : $BBLOCK; LOCALS5 expand_buffer : VOLATILE VECTOR[NAM$C_MAXRSS, BYTE],5 result_buffer : VOLATILE VECTOR[NAM$C_MAXRSS, BYTE],e this_xabfhc : VOLATILE $XABFHC( ), this_xabdat : VOLATILE $XABDAT( NXT = this_xabfhce ), this_nam : VOLATILE $NAM( ESA = expand_buffer,% ESS = %ALLOCATION(expand_buffer), NOP = ,  RSA = result_buffer,& RSS = %ALLOCATION(result_buffer)), this_fab : VOLATILE $FAB( DNM = '*.*;*', FNA = .path[DSC$A_POINTER],d FNS = .path[DSC$W_LENGTH], FOP = , NAM = this_nam,m XAB = this_xabdat),% size_used, status;$ status = $PARSE(FAB = this_fab);( IF NOT .status THEN SIGNAL(.status); WHILE 1' DO BEGIN this_nam[NAM$V_SRCHXABS] = 1; this_fab[FAB$V_NAM] = 1; " status = $SEARCH(FAB = this_fab);' IF .status EQL RMS$_NMF THEN EXITLOOP;p% IF NOT .status THEN SIGNAL(.status);; !++6 ! Now, we shouldn't have to do this if SRCHXABS would? ! work as I expect. However, I've evidently missed something.r ! Dale Moore. !-- status = $OPEN(FAB = this_fab); $CLOSE(FAB = this_fab);% size_used = .this_xabfhc[XAB$L_EBK]; IF .size_used EQL 0& THEN size_used = .this_fab[FAB$L_ALQ]& ELSE IF .this_xabfhc[XAB$W_FFB] EQL 0! THEN size_used = .size_used - 1;1 IF(NOT .status) AND(.this_nam[NAM$B_RSL] GTR 44)I THEN text_fao_append(text,/ %ASCID '!AF!/!52< !> ',= .this_nam[NAM$B_RSL], .this_nam[NAM$L_RSA]): ELSE IF(NOT .status) AND NOT(.this_nam[NAM$B_RSL] GTR 44) THEN text_fao_append(text,e0 %ASCID '!44!8< !>', .this_nam[NAM$B_RSL], .this_nam[NAM$L_RSA])2 ELSE IF(.status) AND(.this_nam[NAM$B_RSL] GTR 44) THEN text_fao_append(text,P- %ASCID '!AF!/!44< !>!8UL/!10!17%D', .this_nam[NAM$B_RSL], .this_nam[NAM$L_RSA], .size_used, .this_fab[FAB$L_ALQ], this_xabdat[XAB$Q_RDT])6 ELSE IF(.status) AND NOT(.this_nam[NAM$B_RSL] GTR 44) THEN text_fao_append(text,a* %ASCID '!44!8UL/!10!17%D', .this_nam[NAM$B_RSL], .this_nam[NAM$L_RSA], .size_used,