!     FILE NAME:  DELTREE.BAS
	!        AUTHOR:  PAUL ST. AMAND
	! CREATION DATE:  03/31/89
	! REVISION DATE:  05/03/89 PSA added macro routine FILE_ALQ, file size
	! REVISION DATE:  04/30/89 PSA added standard VMS Message
	!      LOCATION:  HSTC
	!     MAINFRAME:  VAX 11/780
	!        SYSTEM:  VAX/VMS V4.6
	!      LANGUAGE:  VAX BASIC V3.2
	!   DESCRIPTION:  conversion of DELTREE written in PLI by Dale Miller
	!   DESCRIPTION:  true /LOG support from LIB$DELETE
	!   DESCRIPTION:  added /CONFIRM
	! ---------------------------------------------------------------------
	OPTION TYPE = EXPLICIT

	EXTERNAL LONG FUNCTION CLI$GET_VALUE, &
	                       CLI$PRESENT, &
	                       LIB$FIND_FILE, &
	                       LIB$STOP, &
	                       LOG_RTN, &
	                       ERR_RTN, &
	                       CONF_RTN

	EXTERNAL LONG CONSTANT RMS$_NORMAL
	EXTERNAL LONG CONSTANT DELTREE_INVDIR, &
	                       DELTREE_TOTAL

	COMMON (LOG_COM) LONG LOG_ADDR%
	COMMON (CONF_COM) LONG CONF_ADDR%
	COMMON (ERR_COM) LONG ERR_ADDR%
	COMMON (TOTAL_COM) LONG TOTAL%
	COMMON (BLOCKS_COM) LONG BLOCKS%
	TOTAL% = 0%

	DECLARE STRING DIRNAME$,        &
	               FILE_TO_DELETE$, &
	               ROOT_DIR$

	DECLARE LONG STAT%,   &
	             D_LEN%,  &
	             IND%,    &
	             I%,      &
	             CONTEXT%

	OPEN "TT" AS FILE #1%			!open terminal device for I/O

	STAT% = CLI$PRESENT("LOG")		!check for /LOG qualifier
	LOG_ADDR% = 0%				!set to 0 if not logging
	LOG_ADDR% = LOC(LOG_RTN) IF (STAT% AND 1%) !get address of log_rtn
	
	ERR_ADDR% = LOC(ERR_RTN)		!get address of err_rtn

	STAT% = CLI$PRESENT("CONFIRM")		!check for /CONFIRM qualifier
	CONF_ADDR% = 0%				!set to 0% if no confirmation
	CONF_ADDR% = LOC(CONF_RTN) IF (STAT% AND 1%)  !get address of conf_rtn

	STAT% = CLI$GET_VALUE("DIRECTORY", DIRNAME$)  !get name of directory to 
	CALL LIB$STOP(STAT%) IF (STAT% AND 1%) <> 1%  !delete from command line

	D_LEN% = INSTR(1%, DIRNAME$, "]")

	CALL LIB$STOP(DELTREE_INVDIR BY VALUE, &
	              1% BY VALUE, &
	              DIRNAME$)	IF (D_LEN% = 0%) OR &
	                           (RIGHT$(DIRNAME$, D_LEN% + 1%) <> " ")
	
	IF INSTR(1%, DIRNAME$, ".") = 0% THEN
	  IND% = INSTR(1%, DIRNAME$, "[")
	  CALL LIB$STOP(DELTREE_INVDIR BY VALUE, &
	                1% BY VALUE, &
	                DIRNAME$) IF IND% = 0%

	  FILE_TO_DELETE$ = MID$(DIRNAME$, 1%, IND% - 1%) + &
	                  "[000000]" + &
	                  MID$(DIRNAME$, IND% + 1%, &
	                      (INSTR(1%, DIRNAME$, "]") - IND% - 1%)) + &
	                  ".DIR;*"
	ELSE
	  I% = D_LEN%
	  UNTIL MID$(DIRNAME$, I%, 1%) = "."
	    FILE_TO_DELETE$ = MID$(DIRNAME$, 1%, I% - 2%) + "]" + &
	                      MID$(DIRNAME$, I%, D_LEN% - I%) + ".DIR;*"
	    I% = I% - 1%
	  NEXT
	END IF
						!we have a valid directory spec
						!check if the directory exists
	STAT% = LIB$FIND_FILE (FILE_TO_DELETE$, ROOT_DIR$, CONTEXT%)
	CALL LIB$STOP(DELTREE_INVDIR BY VALUE, &
	              1% BY VALUE, &
	              DIRNAME$) IF STAT% <> RMS$_NORMAL

	CALL DELROUT(DIRNAME$)			!start recursive delete routine
	
	CALL DELETE_FILE$ (ROOT_DIR$)		!delete the final directory

	CLOSE #1%

	CALL LIB$SIGNAL(DELTREE_TOTAL BY VALUE, &
	                2% BY VALUE, &
	                TOTAL% BY VALUE, &
	                BLOCKS% BY VALUE) IF (TOTAL% > 1%) AND &
	                                     (LOG_ADDR% <> 0%)
	END
!
! DELETE_FILE$ subroutine
!
	SUB DELETE_FILE$ (STRING FILE_NAME$)

	  OPTION TYPE = EXPLICIT

	  EXTERNAL LONG FUNCTION LIB$DELETE_FILE, &
	                         LIB$FIND_FILE, &
	                         LIB$STOP , &
	                         CLI$PRESENT, &
	                         FILE_ALQ(LONG BY VALUE,STRING BY REF)

	  EXTERNAL LONG CONSTANT RMS$_NORMAL

	  COMMON (LOG_COM) LONG LOG_ADDR%
	  COMMON (ERR_COM) LONG ERR_ADDR%
	  COMMON (CONF_COM) LONG CONF_ADDR%

	  DECLARE LONG STAT%, &
	               FILESIZE%

	  FILESIZE% = 0%
	  FILESIZE% = FILE_ALQ(LEN(FILE_NAME$), FILE_NAME$) IF (LOG_ADDR% <> 0%)

	  STAT% = LIB$DELETE_FILE (FILE_NAME$, &
	                           "", &
	                           "", &
	                           LOG_ADDR% BY VALUE, &
	                           ERR_ADDR% BY VALUE, &
	                           CONF_ADDR% BY VALUE, &
	                           FILESIZE% BY REF)
	END SUB
!
! LOG_RTN called by LIB$DELETE_FILE if /LOG switch and successful delete
!
	FUNCTION LONG LOG_RTN (STRING FILE$, LONG FILESIZE% BY REF)

	  OPTION TYPE = EXPLICIT

	  COMMON (TOTAL_COM) LONG TOTAL%
	  COMMON (BLOCKS_COM) LONG BLOCKS%

	  EXTERNAL LONG FUNCTION LIB$SIGNAL
	  EXTERNAL LONG CONSTANT DELTREE_FILDELT

	  BLOCKS% = BLOCKS% + FILESIZE%

	  CALL LIB$SIGNAL(DELTREE_FILDELT BY VALUE, &
	                  2% BY VALUE, &
	                  FILE$, &
	                  FILESIZE% BY VALUE) 

	  TOTAL% = TOTAL% + 1%
	END FUNCTION
!
! ERR_RTN called by LIB$DELETE_FILE if error occurs deleting file
!
	FUNCTION LONG ERR_RTN (STRING FILE$, &
	                       LONG RMS_STS%, &
	                       LONG RMS_STV%, &
	                       LONG ERROR_SOURCE%, &
	                       LONG D%)

	OPTION TYPE = EXPLICIT

	EXTERNAL LONG FUNCTION LIB$SIGNAL

	EXTERNAL LONG CONSTANT DELTREE_FAILSEARCH, &
	                       DELTREE_FILNOTDEL, &
	                       DELTREE_ERRNOTKNOWN

	  SELECT ERROR_SOURCE%			!what caused the error condition
	    CASE 0%
	      CALL LIB$SIGNAL(DELTREE_FAILSEARCH BY VALUE, &
	                      1% BY VALUE, &
	                      FILE$)
	    CASE 1%
	      CALL LIB$SIGNAL(DELTREE_FILNOTDEL BY VALUE, &
	                      1% BY VALUE, &
	                      FILE$)
	    CASE ELSE
	      CALL LIB$SIGNAL(DELTREE_ERRNOTKNOWN BY VALUE, &
	                      1% BY VALUE, &
	                      FILE$)
	  END SELECT
	  CALL LIB$SIGNAL(RMS_STS% BY VALUE, &
	                  RMS_STV% BY VALUE)
	END FUNCTION
!
! CONF_RTN called by LIB$DELETE_FILE if /CONFIRM switch is enabled
!
	FUNCTION LONG CONF_RTN (STRING FILE$, &
	                        LONG A%, &
	                        LONG B%)	!confirm routine mimick's DELETE

	  OPTION TYPE = EXPLICIT

	  EXTERNAL LONG FUNCTION LIB$STOP, &
	                         STR$UPCASE

	  COMMON (CONF_COM) LONG CONF_ADDR%
	  
	  DECLARE BYTE EXIT%
	  DECLARE STRING CONF$
	  DECLARE LONG CONF%, &
	               STAT%

	  EXIT% = 0%	
	  WHILE EXIT% <> 1%
	    PRINT #1%, FILE$; ", delete? [N]:";
	    WHEN ERROR IN			!force ^Z to work properly
	      INPUT #1%, CONF$
	    USE
	      SELECT ERR
	        CASE 11%			!end of file (^Z)
	        CASE 47%			!line to long
	          PRINT #1%
	          ITERATE
	        CASE ELSE			!oops real error occurred
	          PRINT #1%
	          PRINT #1%, ERT$(ERR)
	          CALL LIB$STOP(0%)
	      END SELECT
	    END WHEN

	    STAT% = STR$UPCASE(CONF$, CONF$)	!force conf$ to upper case
	    CALL LIB$STOP(STAT%) IF (STAT% AND 1%) <> 1%

	    CONF% = 2%
	    SELECT CONF$
	      CASE "", "0", &
	           LEFT$("FALSE", LEN(CONF$)), &
	           LEFT$("NO", LEN(CONF$))	!chops characters in literal 
		                                !at length of CONF$ if CONF$
	                                        !is short
	        CONF% = 0%
	      CASE "1", &
	           LEFT$("TRUE", LEN(CONF$)), &
	           LEFT$("YES", LEN(CONF$))
	        CONF% = 1%
	      CASE LEFT$("ALL", LEN(CONF$))
	        CONF_ADDR% = 0%
	        CONF% = 1%
              CASE LEFT$("QUIT", LEN(CONF$))
	        CALL LIB$STOP(0%)
	    END SELECT
	    EXIT% = 1% IF CONF% <> 2%		!do we have valid input
	  NEXT					!if not loop back
	  CONF_RTN = CONF%			!assign answer
	END FUNCTION
!
! recursive delete deletion subroutine
!
	SUB DELROUT(STRING DIRNAME$)

	  OPTION TYPE = EXPLICIT

	  EXTERNAL INTEGER FUNCTION LIB$FIND_FILE, &
	                            LIB$STOP

	  EXTERNAL INTEGER CONSTANT RMS$_NMF, &
	                            RMS$_FNF

	  EXTERNAL SUB DELETE_FILE$

	  DECLARE STRING FILE_TO_DELETE$, &
	                 FILENAME$

	  DECLARE LONG STAT%, &
	               CONTEXT%, &
	               IND%

	  CONTEXT% = 0%
	
	  STAT% = LIB$FIND_FILE(DIRNAME$+"*.*;*", FILE_TO_DELETE$, CONTEXT%)
	  WHILE (STAT% <> RMS$_NMF) AND (STAT% <> RMS$_FNF)
	    IF INSTR(1%, FILE_TO_DELETE$, ".DIR") <> 0% THEN
	      IND% = INSTR(1%, FILE_TO_DELETE$, "]")
	      FILENAME$ = MID$(FILE_TO_DELETE$, IND% + 1%, &
	                  INSTR(1%, FILE_TO_DELETE$, ";") - IND% -5%)
	      CALL DELROUT(MID$(FILE_TO_DELETE$, 1%, IND% - 1%) + &
	                   "." + FILENAME$ + "]")
	    END IF

	    CALL DELETE_FILE$ (FILE_TO_DELETE$)	!delete the file

	    STAT% = LIB$FIND_FILE (DIRNAME$ + "*.*;*", &
	                           FILE_TO_DELETE$, &
	                           CONTEXT%)
	  NEXT
	END SUB