!+ ! NAME ! LNKCHK_TEST_LINK -- Main module for LINK_CHECK tool ! ! DESCRIPTION ! The Link Check tool verifies all of the files in a LINK ! statement for existence and if they all exist, passes ! the LINK command through to the VMS Linker. ! ! This tool is a workaround for a bug in the Linker that ! causes it to go into an endless loop when it can't ! find a file (particularly when associated with a ! searchlist). ! ! This tool verifies all linker input files for existence: ! ! Object Files (no qualifier) ! Library Files (/LIBRARY or /INCLUDE) ! Options Files (/OPTIONS) ! ! In the case of OPTIONs files, it calls a tool called ! OPTCHECK that verifies the existence of all object files ! in an link options file. ! ! SCAN was chosen for this tool because of its easy interface ! to the CLI utilities. No actual text scanning is performed. ! ! ! ERROR REPORTING ! The VMS message utility is used to report any files that ! do not exist (also used by OPTCHECK). One error message ! per missing file is generated and a fatal exit error ! message is generated when the program terminates if any ! files were missing. ! ! RETURN VALUE ! ! HISTORY ! 5/23/88 Bauer Initial implementation. ! 12/19/88 Bauer SPR.15439 - Add $ SET NOON to command procedure ! - Temp file name to ___LNKCHK.COM ! - Fix bug of duplicate error messages when ! error found in earlier options file ! !- MODULE LINK$CHECK IDENT 'v1.0'; ! ! Type definitions ! TYPE MSG_VECTOR: ! For SYS$PUTMSG calls RECORD arg_count : INTEGER, ! Length of message vector message_code : INTEGER, ! Error message code fao_param_count : INTEGER, ! How many FAO parameters (0 - 1) fao_p1 : POINTER TO STRING, ! First FAO parameter (optional) END RECORD; ! ! Constant Declaration ! CONSTANT LNKCHK_NOOBJECT EXTERNAL INTEGER; ! Object file not found CONSTANT LNKCHK_NOOPTIONS EXTERNAL INTEGER; ! Library file not found CONSTANT LNKCHK_NOLIBRARY EXTERNAL INTEGER; ! Options file not found CONSTANT LNKCHK_OPTIONSERR EXTERNAL INTEGER; ! Errors in options file CONSTANT LNKCHK_TOOLONG EXTERNAL INTEGER; ! Command too long CONSTANT LNKCHK_MISSING EXTERNAL INTEGER; ! Fatal exit error CONSTANT LNKCHK_CANTCRECOM EXTERNAL INTEGER; ! Can't create COM file CONSTANT LNKCHK_OKAY EXTERNAL INTEGER; ! Alls well in Denmark CONSTANT LNKCHK_NOPASS EXTERNAL INTEGER; ! Alls well in Denmark but don't execute LINK CONSTANT CLI$_ABSENT EXTERNAL INTEGER; ! End of input list hit CONSTANT CLI$_PRESENT EXTERNAL INTEGER; ! Qualifier exists CONSTANT CLI$_LOCPRES EXTERNAL INTEGER; ! Local qualifier exists CONSTANT SS$_NORMAL EXTERNAL INTEGER; ! Good status CONSTANT HEX_F0000 = 983040; ! SYS$PUTMSG print flags ! ! Global Variables ! DECLARE exit_status_flag : INTEGER; ! Exit status used in LIB$SIGNAL ! ! EXTERNAL PROCEDURE Declarations ! EXTERNAL PROCEDURE LIB$FIND_FILE (STRING, STRING, INTEGER) OF BOOLEAN; ! To check for existence of a file EXTERNAL PROCEDURE LIB$SIGNAL ( VALUE INTEGER, VALUE INTEGER ); ! For error exits ! ! Procedures follow ! !+ ! NAME ! print_warning -- prints a warning message when a file is missing ! ! DESCRIPTION ! This procedure gets called whenever an object, options, or ! library file cannot be found from the link statement. ! It uses the system service routine SYS$PUTMSG and the ! VMS message mutility to output an error message. ! ! RETURN VALUE ! ! HISTORY ! 5/24/88 Bauer First cut. ! !- PROCEDURE print_warning ( message_code : INTEGER, for_what_file : STRING ); EXTERNAL PROCEDURE SYS$PUTMSG ( MSG_VECTOR, FILL(4), FILL(4), FILL(4) ); DECLARE msgvec : MSG_VECTOR; ! SYS$PUTMSG mesasge vector IF for_what_file <> '' THEN msgvec.arg_count = HEX_F0000 + 3; ! Set up the message vector msgvec.message_code = message_code; msgvec.fao_param_count = 1; msgvec.fao_p1 = POINTER (for_what_file); ! This is alwaysthe expanded file name ELSE msgvec.arg_count = HEX_F0000 + 2; ! Set up the message vector msgvec.message_code = message_code; msgvec.fao_param_count = 0; END IF; CALL SYS$PUTMSG(msgvec, *, *, * ); END PROCEDURE; !+ ! NAME ! setup_link_command -- cleans up string to pass to linker ! ! DESCRIPTION ! This procedure substitutes the string LINK for the LNKCHK ! verb in perparation for executing the link command. ! ! RETURN VALUE ! ! HISTORY ! 5/25/88 Bauer First cut. ! !- PROCEDURE setup_link_command ( from_command : STRING, exec_name : STRING ); DECLARE com_length : INTEGER; DECLARE i : INTEGER; DECLARE status : INTEGER; EXTERNAL PROCEDURE LIB$DO_COMMAND ( STRING ) OF INTEGER; EXTERNAL PROCEDURE process_long_link_command (STRING, STRING) OF INTEGER; com_length = LENGTH(from_command); FOR i = 1 to com_length STEP 1; ! Find first space or option after LNKCHK ! command ... IF from_command[i..i] = '/' OR from_command[i..i] = ' ' THEN from_command = 'LINK' & from_command[i..]; ! Replace it with LINK i = com_length; END IF; END FOR; IF com_length < 254 THEN status = LIB$DO_COMMAND ( from_command ); ! And pass it to LIB$DO_COMMAND IF status <> SS$_NORMAL THEN CALL lib$signal (status, 0); END IF; ELSE CALL print_warning (LNKCHK_TOOLONG, ''); IF process_long_link_command (from_command, exec_name) = 1 ! Handle long commands THEN status = LIB$DO_COMMAND ( '@' & exec_name ); IF status <> SS$_NORMAL THEN CALL lib$signal (status, 0); END IF; ELSE CALL lib$signal (LNKCHK_CANTCRECOM, 0);; END IF; END IF; END PROCEDURE; !+ ! NAME ! get_file_name -- extracts a file name from a complete file spec ! ! DESCRIPTION ! This procedure extracts a file name without version number ! from a complete file spec that is either the form: ! ! any_logical:any_file.any_extension;any_version ! - OR - ! ...[ ... ]any_file.any_extension;any_version ! ! and returns a string that looks like: ! ! any_file.any_extension ! ! RETURN VALUE ! ! HISTORY ! 5/24/88 Bauer First cut. ! !- PROCEDURE get_file_name ( from_file : STRING, and_the_name_is : STRING ); DECLARE logical_dir_spec : INTEGER; DECLARE actual_dir_spec : INTEGER; DECLARE file_name_length : INTEGER; DECLARE version_number : INTEGER; DECLARE i : INTEGER; logical_dir_spec = INDEX (from_file, ':'); ! Logical name with file? IF logical_dir_spec <> 0 THEN and_the_name_is = from_file[(logical_dir_spec+1) ..]; ELSE file_name_length = LENGTH(from_file); ! No - [....] type FOR i = file_name_length to 1 STEP -1; IF from_file[i..i] = ']' THEN and_the_name_is = from_file[(i+1) ..]; i = 1; END IF; END FOR; IF and_the_name_is = '' THEN and_the_name_is = from_file; END IF; END IF; version_number = INDEX(and_the_name_is, ';'); ! Get rid of version number from name IF version_number <> 0 THEN and_the_name_is = and_the_name_is[1 .. (version_number-1)]; END IF; END PROCEDURE; !+ ! NAME ! get_file_extension -- extracts a extension from a file name ! ! DESCRIPTION ! This procedure extracts a file extension from file name strings of ! form: ! any_file.any_extension ! ! and returns: ! .any_extension ! ! or the NULL string. ! ! RETURN VALUE ! ! HISTORY ! 5/24/88 Bauer First cut. ! !- PROCEDURE get_file_extension ( from_file : STRING, and_the_extension_is : STRING ); DECLARE extension_spot : INTEGER; DECLARE from_file_name : STRING; CALL get_file_name (from_file, from_file_name); ! Get the file name portion extension_spot = INDEX(from_file_name, '.'); ! Search for extension IF extension_spot <> 0 THEN and_the_extension_is = from_file_name[ extension_spot .. ]; ELSE and_the_extension_is = ''; END IF; END PROCEDURE; !+ ! NAME ! check_for_library_file -- checks for existence of a library ! ! DESCRIPTION ! This routine uses lib$find_file to search for an ! library file. It also concatenates the default ! file type if the type was not specified. ! ! RETURN VALUE ! ! HISTORY ! 5/24/88 Bauer First cut. ! !- PROCEDURE check_for_library_file (what_olb_file : STRING); DECLARE full_file_name : STRING; DECLARE extension : STRING; DECLARE context : INTEGER; CALL get_file_extension (what_olb_file, extension); ! Get extension IF extension = '' THEN ! If not there add default what_olb_file = what_olb_file & '.OLB'; END IF; context = 0; IF NOT lib$find_file (what_olb_file, full_file_name, context) ! Find the file THEN CALL print_warning ( LNKCHK_NOLIBRARY, full_file_name ); ! Not there - print error message exit_status_flag = LNKCHK_MISSING; END IF; END PROCEDURE; !+ ! NAME ! check_options_file_contents -- checks options file contents ! ! DESCRIPTION ! This routine uses lib$spawn to execute a command file that ! calls OPTCHECK to verify an OPTIONS file contents. ! ! RETURN VALUE ! ! HISTORY ! 5/24/88 Bauer First cut. ! !- PROCEDURE check_options_file_contents ( for_options_file : STRING ); EXTERNAL PROCEDURE OPTCHECK (STRING, INTEGER) OF INTEGER; DECLARE completion_status : INTEGER; completion_status = OPTCHECK (for_options_file, LENGTH(for_options_file) ); IF completion_status <> SS$_NORMAL ! Check completion status THEN CALL print_warning ( LNKCHK_OPTIONSERR, for_options_file ); ! Error completion status exit_status_flag = LNKCHK_MISSING; END IF; END PROCEDURE; !+ ! NAME ! check_options_file -- checks for existence of options file ! ! DESCRIPTION ! This routine uses lib$find_file to search for an options ! file. If it exists is calls a routine that will call ! the OPTCHECK tool to verify the OPTIONS file contents. ! It also concatenates the default file type if the type ! was not specified. ! ! RETURN VALUE ! ! HISTORY ! 5/24/88 Bauer First cut. ! !- PROCEDURE check_options_file (what_opt_file : STRING); DECLARE full_file_name : STRING; DECLARE extension : STRING; DECLARE context : INTEGER; CALL get_file_extension (what_opt_file, extension); ! Get the extension IF extension = '' THEN ! If not there, add one for search what_opt_file = what_opt_file & '.OPT'; END IF; context = 0; IF NOT lib$find_file (what_opt_file, full_file_name, context) ! Is it there? THEN CALL print_warning ( LNKCHK_NOOPTIONS, full_file_name ); ! No - print error exit_status_flag = LNKCHK_MISSING; ELSE CALL check_options_file_contents ( full_file_name ); ! Yes - check options file contents END IF; END PROCEDURE; !+ ! NAME ! check_for_object_file -- checks for existence of object file ! ! DESCRIPTION ! This routine uses lib$find_file to search for an ! object file. It also concatenates the default ! file type if the type was not specified. ! ! RETURN VALUE ! ! HISTORY ! 5/24/88 Bauer First cut. ! !- PROCEDURE check_for_object_file (what_obj_file : STRING); DECLARE full_file_name : STRING; DECLARE extension : STRING; DECLARE context : INTEGER; CALL get_file_extension (what_obj_file, extension); ! Get extension IF extension = '' THEN ! If not there add default extension what_obj_file = what_obj_file & '.OBJ'; END IF; context = 0; IF NOT lib$find_file (what_obj_file, full_file_name, context) ! Is the file there? THEN CALL print_warning ( LNKCHK_NOOBJECT, full_file_name ); ! No - print error message exit_status_flag = LNKCHK_MISSING; END IF; END PROCEDURE; !+ ! NAME ! lnkchk_main -- main program for link_check tool. ! ! DESCRIPTION ! This routine drives the link_check tool by parsing out ! input files by using the CLI utilities. It also ! checks for the existence of qualifiers inorder to ! determine if the input file is an options file or ! library. ! ! RETURN VALUE ! ! HISTORY ! 5/24/88 Bauer First cut. ! !- PROCEDURE lnkchk_main MAIN; EXTERNAL PROCEDURE CLI$GET_VALUE (STRING, STRING, INTEGER) OF INTEGER; ! To extract input files EXTERNAL PROCEDURE CLI$PRESENT (STRING) OF INTEGER; ! To test for qualifiers DECLARE input_file : STRING; ! Input link file DECLARE whole_command : STRING; DECLARE exec_name : STRING; exit_status_flag = LNKCHK_OKAY; ! Assume that we have a valid link command WHILE CLI$GET_VALUE ('NEXT_INPUT_FILE', input_file, *) ! Pull out input files and <> CLI$_ABSENT; IF CLI$PRESENT ('LIBRARY') = CLI$_LOCPRES OR ! Check to see if they are library, CLI$PRESENT ('INCLUDE') = CLI$_LOCPRES THEN CALL check_for_library_file (input_file); ELSE IF CLI$PRESENT ('OPTIONS') = CLI$_LOCPRES ! options, THEN CALL check_options_file (input_file); ELSE CALL check_for_object_file (input_file); ! or object files ... END IF; END IF; END WHILE; IF exit_status_flag <> LNKCHK_OKAY ! If we had an error, then bubble THEN ! back a fatal exit status. CALL LIB$SIGNAL( exit_status_flag, 0 ); ELSE IF CLI$PRESENT('NOPASS') = CLI$_PRESENT ! /NOPASS? THEN CALL LIB$SIGNAL( LNKCHK_NOPASS, 0 ); ! Then exit with success/nopass message ELSE exec_name = '___LNKCHK_TMP.COM'; IF CLI$GET_VALUE('$LINE', whole_command, *) ! Else execute the LINK command <> CLI$_ABSENT THEN CALL setup_link_command (whole_command, exec_name); END IF; END IF; END IF; END PROCEDURE; END MODULE;