IDENTIFICATION DIVISION. PROGRAM-ID. RENAME-FILE-WITH-CONF. * * Creation Date: 27-JUL-1990 * * Author: THE VASTEK COMPANY * * Modification History: * * Functional Description: * * Sample program to rename a file. This program will print messages * on success and error, and will also prompt for confirmation. * * Calling Format: $ RUN RENAME-FILE-WITH-CONF * Formal Arguments: None * Implicit Inputs: None * Implicit Outputs: None * Side Effects: None * DATA DIVISION. WORKING-STORAGE SECTION. 01 WS-OLD. 02 OLD PIC X(255). 02 OLD-LEN PIC S9(9) COMP. 01 WS-NEW. 02 NEW PIC X(255). 02 NEW-LEN PIC S9(9) COMP. 01 RETURN-STATUS PIC S9(9) COMP. 01 WS-EXTERNAL-ROUTINES. 02 SUCCESS-RTN-A PIC S9(9) COMP VALUE EXTERNAL SUCCESS-RTN. 02 ERROR-RTN-A PIC S9(9) COMP VALUE EXTERNAL ERROR-RTN. 02 CONF-RTN-A PIC S9(9) COMP VALUE EXTERNAL CONF-RTN. PROCEDURE DIVISION. BEGIN. * * Issue read with prompts to request the old and new file * specifications. * CALL 'LIB$GET_INPUT' USING BY DESCRIPTOR OLD BY DESCRIPTOR 'Old File: ' BY REFERENCE OLD-LEN GIVING RETURN-STATUS. IF RETURN-STATUS IS FAILURE THEN CALL 'LIB$STOP' USING BY VALUE RETURN-STATUS. CALL 'LIB$GET_INPUT' USING BY DESCRIPTOR NEW BY DESCRIPTOR 'New File: ' BY REFERENCE NEW-LEN GIVING RETURN-STATUS. IF RETURN-STATUS IS FAILURE THEN CALL 'LIB$STOP' USING BY VALUE RETURN-STATUS. * * Rename the file. * The action routines will be called and perform as required. * CALL 'LIB$RENAME_FILE' USING BY DESCRIPTOR OLD(1:OLD-LEN) BY DESCRIPTOR NEW(1:NEW-LEN) BY VALUE 0 0 0 BY VALUE SUCCESS-RTN-A BY VALUE ERROR-RTN-A BY VALUE CONF-RTN-A GIVING RETURN-STATUS. IF RETURN-STATUS IS FAILURE THEN CALL 'LIB$STOP' USING BY VALUE RETURN-STATUS. DISPLAY 'Rename complete.'. STOP RUN. END PROGRAM RENAME-FILE-WITH-CONF. / IDENTIFICATION DIVISION. PROGRAM-ID. SUCCESS-RTN. * * Creation Date: 27-JUL-1990 * * Author: THE VASTEK COMPANY * * Modification History: * * Functional Description: * * This routine prints a success message displaying the * files involved in the rename. * * Calling Format: CALL "SUCCESS-RTN" USING OLD-PTR NEW-PTR * GIVING RETURN-STATUS * * Formal Arguments: OLD-PTR * VMS Usage: address of descriptor * Type: longword (unsigned) * Access: read only * Mechanism: by reference * Description: Pointer to descriptor for OLD string. * * OLD-PTR * VMS Usage: address of descriptor * Type: longword (unsigned) * Access: read only * Mechanism: by reference * Description: Pointer to descriptor for NEW string. * * RETURN-STATUS * VMS Usage: cond_value * Type: longword (unsigned) * Access: write only * Mechanism: by value * Description: Condition value returned. * * Implicit Inputs: None * Implicit Outputs: None * Side Effects: None * DATA DIVISION. WORKING-STORAGE SECTION. 01 WS-OLD. 02 OLD PIC X(255). 02 OLD-LEN PIC 9(4) COMP. 01 WS-NEW. 02 NEW PIC X(255). 02 NEW-LEN PIC 9(4) COMP. 01 RETURN-STATUS PIC S9(9) COMP. LINKAGE SECTION. 01 OLD-PTR USAGE POINTER. 01 NEW-PTR USAGE POINTER. PROCEDURE DIVISION USING OLD-PTR NEW-PTR. BEGIN. * * Obtain the strings passed to this routine BY DESCRIPTOR * CALL "MAKE-COB-DESC" USING OLD-PTR OLD OLD-LEN GIVING RETURN-STATUS. IF RETURN-STATUS IS FAILURE THEN CALL "LIB$STOP" USING BY VALUE RETURN-STATUS. CALL "MAKE-COB-DESC" USING NEW-PTR NEW NEW-LEN GIVING RETURN-STATUS. IF RETURN-STATUS IS FAILURE THEN CALL "LIB$STOP" USING BY VALUE RETURN-STATUS. * * inform the user of our success * DISPLAY OLD(1:OLD-LEN) ' renamed to ' NEW(1:NEW-LEN). EXIT PROGRAM. END PROGRAM SUCCESS-RTN. / IDENTIFICATION DIVISION. PROGRAM-ID. ERROR-RTN. * * Creation Date: 27-JUL-1990 * * Author: THE VASTEK COMPANY * * Modification History: * * Functional Description: * * This routine prints an error message specifying the errant files. * * Calling Format: CALL "ERROR-RTN" USING OLD-PTR NEW-PTR * GIVING RETURN-STATUS * * Formal Arguments: OLD-PTR * VMS Usage: address of descriptor * Type: longword (unsigned) * Access: read only * Mechanism: by reference * Description: Pointer to descriptor for OLD string. * * OLD-PTR * VMS Usage: address of descriptor * Type: longword (unsigned) * Access: read only * Mechanism: by reference * Description: Pointer to descriptor for NEW string. * * RETURN-STATUS * VMS Usage: cond_value * Type: longword (unsigned) * Access: write only * Mechanism: by value * Description: Condition value returned. * * Implicit Inputs: None * Implicit Outputs: None * Side Effects: None * DATA DIVISION. WORKING-STORAGE SECTION. 01 WS-OLD. 02 OLD PIC X(255). 02 OLD-LEN PIC S9(4) COMP. 01 WS-NEW. 02 NEW PIC X(255). 02 NEW-LEN PIC S9(4) COMP. 01 RETURN-STATUS PIC S9(9) COMP. LINKAGE SECTION. 01 OLD-PTR USAGE POINTER. 01 NEW-PTR USAGE POINTER. PROCEDURE DIVISION USING OLD-PTR NEW-PTR. BEGIN. * * Obtain the strings passed to this routine BY DESCRIPTOR * CALL "MAKE-COB-DESC" USING NEW-PTR NEW NEW-LEN GIVING RETURN-STATUS. IF RETURN-STATUS IS FAILURE THEN CALL "LIB$STOP" USING BY VALUE RETURN-STATUS. CALL "MAKE-COB-DESC" USING OLD-PTR OLD OLD-LEN GIVING RETURN-STATUS. IF RETURN-STATUS IS FAILURE THEN CALL "LIB$STOP" USING BY VALUE RETURN-STATUS. * * inform the user of our failure * DISPLAY 'ERROR renaming ' OLD(1:OLD-LEN) ' to ' NEW(1:OLD-LEN). EXIT PROGRAM. END PROGRAM ERROR-RTN. / IDENTIFICATION DIVISION. PROGRAM-ID. CONF-RTN. * * Creation Date: 27-JUL-1990 * * Author: THE VASTEK COMPANY * * Modification History: * * Functional Description: * * This routine prompts for confirmation of rename. * It will return 0 if the rename is to be aborted. * It will return 1 if the rename is to be continued. * * Calling Format: CALL "CONF-RTN" USING OLD-PTR NEW-PTR * GIVING RETURN-STATUS * * Formal Arguments: OLD-PTR * VMS Usage: address of descriptor * Type: longword (unsigned) * Access: read only * Mechanism: by reference * Description: Pointer to descriptor for OLD string. * * OLD-PTR * VMS Usage: address of descriptor * Type: longword (unsigned) * Access: read only * Mechanism: by reference * Description: Pointer to descriptor for NEW string. * * KILL-STAT * VMS Usage: cond_value * Type: longword (unsigned) * Access: write only * Mechanism: by value * Description: Condition value returned. Used to * control renaming of individual files. * * Implicit Inputs: None * Implicit Outputs: None * Side Effects: Depending on user input, may not rename all files * initially indicated. * DATA DIVISION. WORKING-STORAGE SECTION. 01 RESPONSE PIC X. 01 WS-OLD. 02 OLD PIC X(255). 02 OLD-LEN PIC S9(4) COMP. 01 WS-NEW. 02 NEW PIC X(255). 02 NEW-LEN PIC S9(4) COMP. 01 KILL-STAT PIC S9(9) COMP. 01 RETURN-STATUS PIC S9(9) COMP. LINKAGE SECTION. 01 OLD-PTR USAGE POINTER. 01 NEW-PTR USAGE POINTER. PROCEDURE DIVISION USING OLD-PTR NEW-PTR GIVING KILL-STAT. BEGIN. * * Obtain the strings passed to this routine BY DESCRIPTOR * CALL "MAKE-COB-DESC" USING NEW-PTR NEW NEW-LEN GIVING RETURN-STATUS. IF RETURN-STATUS IS FAILURE THEN CALL "LIB$STOP" USING BY VALUE RETURN-STATUS. CALL "MAKE-COB-DESC" USING OLD-PTR OLD OLD-LEN GIVING RETURN-STATUS. IF RETURN-STATUS IS FAILURE THEN CALL "LIB$STOP" USING BY VALUE RETURN-STATUS. * * Prompt the user for confirmation of the rename. * DISPLAY 'Are you sure you want to rename ' . DISPLAY OLD(1:OLD-LEN) ' to '. DISPLAY NEW(1:NEW-LEN) ' ?'. DISPLAY 'Enter y or Y if you do: ' NO. ACCEPT RESPONSE. * * Assume he wants to abort. * MOVE 0 TO KILL-STAT. * * If he wants to continue the rename, then return an odd value * IF RESPONSE = "Y" OR "y" THEN MOVE 1 TO KILL-STAT. EXIT PROGRAM. END PROGRAM CONF-RTN. / IDENTIFICATION DIVISION. PROGRAM-ID. MAKE-COB-DESC. * * Creation Date: 27-JUL-1990 * * Author: Joe Ruvolo * * Modification History: * * Functional Description: * * Subprogram that will make use of a string descriptor * placed there by a non-COBOL program to obtain the length and * value of the string pointed to by that original descriptor. * * This routine, in essence, allows a COBOL subprogram to receive * data BY REFERENCE (default) and BY DESCRIPTOR. * * Calling Format: CALL "MAKE-COB-DESC" USING STR-PTR STR STR-LEN * GIVING RETURN-STATUS * * Formal Arguments: STR-PTR * VMS Usage: longword * Type: longword (unsigned) * Access: read only * Mechanism: by reference * Description: First longword of descriptor. * * STR * VMS Usage: char_string * Type: character string * Access: write only * Mechanism: by reference * Description: Data record to pass back * the original string. * * STR-LEN * VMS Usage: word_signed * Type: signed word * Access: write only * Mechanism: by reference * Description: Data field to pass back the length * of the original string. * * RETURN-STATUS * VMS Usage: cond_value * Type: longword (unsigned) * Access: write only * Mechanism: by value * Description: Condition value returned. * * Implicit Inputs: None * Implicit Outputs: None * Side Effects: None * DATA DIVISION. WORKING-STORAGE SECTION. 01 DATA-ADDR USAGE POINTER. 01 RETURN-STATUS PIC S9(9) COMP. LINKAGE SECTION. 01 STR-PTR PIC 9(9) COMP. 01 STR PIC X(255). 01 STR-LEN PIC 9(4) COMP. PROCEDURE DIVISION USING STR-PTR STR STR-LEN GIVING RETURN-STATUS. BEGIN. * * use LIB$ANALYZE_SDESC to obtain the address of the original string * and its length. Note that the STR-PTR is NOT passed by DESCRIPTOR * as the RTL manual calls for. We pass by REFERENCE so that the address * of the descriptor already built is analyzed and interpreted. * CALL "LIB$ANALYZE_SDESC" USING BY REFERENCE STR-PTR BY REFERENCE STR-LEN DATA-ADDR GIVING RETURN-STATUS. IF RETURN-STATUS IS SUCCESS THEN * * after successfully analyzing the descriptor, use the RTL version of * the MOVC3 instruction to move the value of the original string into * our COBOL string variable. * CALL "LIB$MOVC3" USING BY REFERENCE STR-LEN BY VALUE DATA-ADDR BY REFERENCE STR END-IF. EXIT PROGRAM. END PROGRAM MAKE-COB-DESC. $! $! This COM file can be used to compile, link and run the program RENAME $! $ COBOL RENAME.COB $ LINK RENAME $ RUN RENAME $ EXIT