C Last Modified:   4-FEB-1994 10:39:08.91, By: RLB14162
c
	Program SLMOD
	implicit none
c
c	Title:	SLMOD.FOR
c
c	Author:	Robert L. Boyd, Harris Semiconductor
c
c	Date:	Nov, 1990
c
c	Abstract:	This program is intended to simplify the manipulation
c			of logical name search lists.  It provides a simple
c	VAX/VMS DCL command line interface to define or update search list
c	logical names.  The most significant features are the easy insertion
c	and deletion of elements in the search list.
c
c	Contributors:	Robert L. Boyd, Fred Stluka, & Jerry Leichter
c
c	Modification History:
c
c	Intls	Date	Notes
c	___________________________________________________________________
c	RLB	2/1/94	Modified DELETE behavior to cover /ITEM=*,m-n
c			and /DELETE=ALL scenarios
c	RLB	4/5/91	Corrected /DELETE behavior and inherited attribute
c			handling.
c	RLB	4/15/91	Converted to universal command interpreter
c			interface.  Corrected access mode default processing.
c
c	RLB	4/23/91	Changed interlock table lookup to actually
c			determine the input and output table name &
c			parents.  Avoid incorrect locks.
c
	integer	sys$trnlnm, sys$crelnm, sys$dellnm, ots$cvt_ti_l
	integer	cli_get_value,cli_present, lib$put_output, sys$getjpi
	integer	str$copy_r, lib$set_symbol, lib$set_logical, dereference,
	1	lib$delete_symbol, lib$delete_logical, slmod_cli_init,
	2	lnm_table_find
c
	include '($lnmdef)'
	include 'climsgdef.inc'
	include '($psldef)'
	include '($ssdef)'
	include '($jpidef)'
	include '($prvdef)'
c
	include 'slmod_structures.inc'

	integer*4	index_table(maximum_items)

	record	/item_list/ lnm_list(maximum_list)
	record  /item_list/ jpi_list(6)
c
	record  /equivalence_strings/ translation(maximum_items)
c
	record  /equivalence_strings/ input_list(maximum_items)
c
c
c
	integer	initial_index, final_index, max_index, move_index, end_index
	integer	first_item, lnm_index, tran_attrib
c
	integer		sym_len, sym_ptr, sym_ctr, name_pointer, tran_len
	integer*2	cmd_len, translation_count, input_count, item_id,
	1		input_item, lnm_len, output_item, hyphen_loc
	integer*4	name_attributes /0/, tran_attributes /0/,
	1		create_mode, input_table_len, input_table_parent_len,
	2		output_table_len, output_table_parent_len,
	3		delete_start, delete_end
c
	integer p2_status, status, input_tlen*2, output_tlen*2, exit_status
	integer indx, list_end, input_attributes /0/, before_index,
	1	after_index, item_index
	logical	after_flag, before_flag, log_flag, insert_flag,
	1	ok_to_delete, item_flag, delete_all /.FALSE./, defaulted
c
	byte		input_access_mode/4/, output_access_mode/4/
c
	character*31	input_table, output_table, logical_name,
	1		input_table_name, input_table_parent,
	2		output_table_name, output_table_parent
	character*255	cmd_item
	character	symbol_name*32, symbol_buffer*32385
	character	tran_string*64
c
c Process the command line
c
c
c See if the command was executed as an external verb or a foreign command
c If $VERB is not equal to SLMOD then it is a foreign command for sure.
c If $LINE starts with <string>:<string> it is probably a foreign command.
c If the symbol SLMOD is defined to be SLMOD =[=] "$SLMOD" and
c the logical SLMOD is defined by DEFINE SLMOD SLMOD_EXE:SLMOD then it
c will be pretty near impossible to distinguish which way it was invoked.
c
	call SLMOD_Cli_Init()
c
c Process Parameters and Qualifiers
c
	status = cli_get_value('Logical_Name',cmd_item,cmd_len)
	logical_name = cmd_item(:cmd_len)
	lnm_len = cmd_len

c
c If the INPUT_TABLE is not explicitly specified there is no access
c mode associated with the input table.  The global qualifier(s) that
c specify access mode apply only to the output table.
c
	output_access_mode = 4
	if( cli_present('USER_MODE').ne.cli$_absent ) then
		output_access_mode = psl$c_user
	else if( (cli_present('SUPERVISOR_MODE').ne.cli$_absent) ) then
		status = cli_present('SUPERVISOR_MODE')
		if( (status.ne.cli$_defaulted))
	1		output_access_mode = psl$c_super
	else if( cli_present('EXECUTIVE_MODE').ne.cli$_absent ) then
		output_access_mode = psl$c_exec
	else if( cli_present('KERNEL_MODE').ne.cli$_absent ) then
		output_access_mode = psl$c_kernel
	endif

d	type *,'INPUT_ACCESS_MODE:',input_access_mode,
d	1	', OUTPUT_ACCESS_MODE:',output_access_mode

c
c Process any specified logical table names
c
	input_tlen = 0
	status = cli_present('OUTPUT_TABLE')
	if( status.eq.cli$_defaulted ) then
c
c workaround for bug in CLI interface routines with lists with
c defaulted values.  Bug present through VMS V5.3-1
c
		Output_Tlen = 11
		Output_Table(1:output_tlen) = 'LNM$PROCESS'
		if( output_access_mode.gt.psl$c_user )
	1	  output_access_mode = psl$c_super
d
d		type *,'OUTPUT_TABLE defaulted:  '//output_table(:output_tlen)
d	1		//', Output_Access_Mode:',output_access_mode
	endif
c
c If the output table was defaulted but there is a /<table>
c qualifier present, honor that qualifier over the defaulted table.
c
	if( cli_present('JOB').ne.cli$_absent ) then
		input_table = 'LNM$JOB'
		input_tlen = 7
		output_table = 'LNM$JOB'
		output_tlen = 7
	else	if( cli_present('GROUP').ne.cli$_absent ) then
		input_table = 'LNM$GROUP'
		input_tlen = 9
		output_table = 'LNM$GROUP'
		output_tlen = 9
	else	if( cli_present('SYSTEM').ne.cli$_absent ) then
		input_table = 'LNM$SYSTEM'
		input_tlen = 10
		output_table = 'LNM$SYSTEM'
		output_tlen = 10
	else	if( cli_present('PROCESS').ne.cli$_absent )then
		input_table = 'LNM$PROCESS'
		input_tlen = 11
		output_table = 'LNM$PROCESS'
		output_tlen = 11
	endif
c
c Process any INPUT_TABLE qualifier value(s)
c
	status = cli_present('INPUT_TABLE')
	if( status.ne.cli$_absent) then
		status = cli_get_value('input_table',cmd_item,cmd_len)
		if( cli_present('input_table.name').ne.cli$_absent) then
		   status = cli_get_value(
	1		'input_table.name',input_table,input_tlen)
		endif
		if( cli_present('input_table.mode').ne.cli$_absent) then
		  status = cli_get_value('input_table.mode',cmd_item,cmd_len)
d	  type *,'INPUT_TABLE_NAME:  '//intput_table(:input_tlen)
d	  type *,'INPUT_ACCESS_MODE:'//cmd_item(:cmd_len)
		  if( cmd_item(:1).eq.'U')  input_access_mode = psl$c_user
		  if( cmd_item(:1).eq.'S')  input_access_mode = psl$c_super
		  if( cmd_item(:1).eq.'E')  input_access_mode = psl$c_exec
		  if( cmd_item(:1).eq.'K')  input_access_mode = psl$c_kernel
		endif
	endif
c
c Process OUTPUT_TABLE qualifier value(s)
c
	status = cli_present('OUTPUT_TABLE')
	if( status.eq.cli$_present ) then
c
d	type *,'Output_Table status:',status
		status = cli_get_value('output_table',cmd_item,cmd_len)
d	type *,'Output_Table:'//cmd_item(:cmd_len)
		status = cli_present('output_table.name')
		if( status.ne.cli$_absent ) then
		  status = cli_get_value(
	1	    'output_table.name',output_table,output_tlen)
		endif
		status = cli_present('output_table.mode')
		if( status.ne.cli$_absent ) then
		  if( status.eq.cli$_defaulted ) then
		    output_access_mode = psl$c_super
		  else
		  status = cli_get_value(
	1		'output_table.mode',cmd_item,cmd_len)
d	  type *,'OUTPUT_ACCESS_MODE:'//cmd_item(:cmd_len)
		  if( output_access_mode.gt.psl$c_user .or.
	1		status.ne.cli$_defaulted ) then
		  if( cmd_item(:1).eq.'U') output_access_mode = psl$c_user
		  if( cmd_item(:1).eq.'S') output_access_mode = psl$c_super
		  if( cmd_item(:1).eq.'E') output_access_mode = psl$c_exec
		  if( cmd_item(:1).eq.'K') output_access_mode = psl$c_kernel
		  endif ! access_mode specified
		  endif ! defaulted
		else ! mode not present (or defaulted?)
		  if( output_access_mode.gt.psl$c_user )
	1		output_access_mode = psl$c_super
		endif
	endif
d	type *,'INPUT_ACCESS_MODE:',input_access_mode,
d	1	', OUTPUT_ACCESS_MODE:',output_access_mode
c
c see if we are to LOG the transaction
c
	status = cli_present('LOG')
	if( status .eq. cli$_present) then
		log_flag = 1
	else
		log_flag = 0
	endif
c
c Find out whether we are Inserting or Deleting
c
c
	if( cli_present('INSERT').ne.cli$_absent) then
		insert_flag = .true.
	endif
	if( cli_present('DELETE').ne.cli$_absent) then
		insert_flag = .false.
c
c see if they have specified DELETE=ALL
c
		status = cli_present('DELETE.ALL')
		if( (status.eq.cli$_locpres).or.(status.eq.cli$_present) ) then
			delete_all = .TRUE.
		else	! they've said /DELETE=NOALL 
			if((status.eq.cli$_locneg).or.(status.eq.cli$_negated) )
	1		ok_to_delete = .FALSE.
		endif	! delete all present
	else if( cli_present('REMOVE').ne.cli$_absent) then
		insert_flag = .false.
c
c see if they have specified DELETE=ALL
c
		status = cli_present('REMOVE.ALL')
		if( (status.eq.cli$_locpres).or.(status.eq.cli$_present) )then
			delete_all = .TRUE.
		else 
			if((status.eq.cli$_locneg).or.(status.eq.cli$_negated) )
	1		ok_to_delete = .FALSE.
		endif	! delete all present
	endif
c
c Is it ok to delete the logical name if the list is empty after
c processing the deletion list?
c
	status = cli_present('EMPTY_DELETE')
	if( status.ne.cli$_absent) then
		ok_to_delete = status.ne.cli$_negated
	endif
c
c Find out whether it will be Before or After
c
	status = cli_present('AFTER')
	if( status.ne.cli$_absent) then
		defaulted = status.eq.cli$_defaulted
		after_flag = .true.
		before_flag = .false.
		status = cli_get_value('AFTER',cmd_item,cmd_len)
c
c Process the after field, if empty then -1 to indicate the end
c
		if( cmd_len.gt.0 ) then
			status = ots$cvt_ti_l(cmd_item(:cmd_len),after_index)
		else
			after_index = -1
		endif
		if( defaulted .and. .not.insert_flag ) then
c
c when deleting and /AFTER is defaulted, set it to start from the beginning
c
			after_index = 0
		endif	! defaulted and delete in progress
	endif	! after selected
c
c Process BEFORE qualifier if present
c
	if( cli_present('BEFORE').ne.cli$_absent) then
		after_flag = .false.
		before_flag = .true.
		status = cli_get_value('BEFORE',cmd_item,cmd_len)
c
c process the before item.  If empty, then it is before the 1st item
c
		if( cmd_len.gt.0) then
			status = ots$cvt_ti_l(cmd_item(:cmd_len),before_index)
		else
			before_index = 0
		endif
	endif
d	TYPE *,'insert_flag:',insert_flag
d	TYPE *,'after_flag:',after_flag,', after_index:',after_index
d	TYPE *,'before_flag:',before_flag,', before_index:',before_index
c
c Determine if any global translation attributes are present.  If so, read
c in all of the values and build a mask of them.
c
	status = cli_present('TRANSLATION_ATTRIBUTES')
	if( 	status.eq.cli$_present
	1	.or.status.eq.cli$_concat
	2	.or.status.eq.cli$_comma
	3	.or.status.eq.cli$_locpres) then
	   status = cli_get_value('TRANSLATION_ATTRIBUTES',cmd_item,cmd_len)
	   if( status.ne.cli$_absent) then
	        status = cli_present('TRANSLATION_ATTRIBUTES.CONCEALED')
d		type *,'TRANSLATION_attributes.Conceal: ',status
		if((status.eq.cli$_locpres).or.(status.eq.cli$_present)) then
		  tran_attributes = lnm$m_concealed.or.tran_attributes
		else if( (status.eq.cli$_locneg) .or.
	1		 (status.eq.cli$_negated) ) then
		  tran_attributes = (.not.lnm$m_concealed).and.tran_attributes
		endif ! concealed_present


		status = cli_present('TRANSLATION_ATTRIBUTES.TERMINAL')
d		type *,'Translation_attributes.Terminal: ',status
		if((status.eq.cli$_locpres).or.(status.eq.cli$_present)) then
		  tran_attributes = lnm$m_terminal.or.tran_attributes
		else if( (status.eq.cli$_locneg) .or.
	1		 (status.eq.cli$_negated) ) then
		  tran_attributes = (.not.lnm$m_terminal).and.tran_attributes
		endif ! terminal_present
	   endif ! TRANSLATION value present
	endif ! TRANSLATION qualifier present
d	type *,'Tran_Attributes:',tran_attributes
c
c Determine if there is an equivalence name present.  If so, read
c in all of the values and build a list of them. Also process translation
c attributes.
c
	input_item = 0
	p2_status = cli_present('Equivalence_Name')
d	type *, 'p2_status:',p2_status
	do while(	p2_status.eq.cli$_present
	1	.or.p2_status.eq.cli$_concat
	2	.or.p2_status.eq.cli$_comma)
c
c Get the next value from the list
c
	  p2_status = cli_get_value('Equivalence_Name',cmd_item,cmd_len)
d	  type *, 'equ_name:'//cmd_item(:cmd_len)
	  if( p2_status.ne.cli$_absent) then
c
c Increment the counter of how many items have been read
c
		input_item = 1+input_item
c
c Store the equivalence string and its length
c
		input_list(input_item).name_length = cmd_len
		input_list(input_item).name_string = cmd_item(:cmd_len)
c
c Set the attributes to the value of the global mask before processing any local
c override.
c
		input_list(input_item).attributes = tran_attributes
c
c Is there any local translation attribute specified? If so, unwind the
c list and store the mask.  Similar to the global one, use cli$_locpres
c
	 	status = cli_present('TRANSLATION_ATTRIBUTES')
	 	if( status.eq.cli$_concat.or. status.eq.cli$_present
	2	.or.status.eq.cli$_comma
	3	.or.status.eq.cli$_locpres) then
		  status = cli_get_value('TRANSLATION_ATTRIBUTES',
	1				cmd_item,cmd_len)
		  if( status.ne.cli$_absent) then
		status = cli_present('TRANSLATION_ATTRIBUTES.CONCEALED')
d		type *,'Translation_attributes.Conceal: ',status
		if( (status.eq.cli$_locpres)
	1		.or. (status.eq.cli$_present)) then
		      input_list(input_item).attributes =
	1	        lnm$m_concealed.or.input_list(input_item).attributes
		else if( (status.eq.cli$_locneg) .or.
	1		 (status.eq.cli$_negated) ) then
		      input_list(input_item).attributes =
	1	        (.not.lnm$m_concealed).and.
	2		input_list(input_item).attributes
		endif ! concealed_present


		status = cli_present('TRANSLATION_ATTRIBUTES.TERMINAL')
d		type *,'Translation_Attributes.Terminal: ',status
		if( (status.eq.cli$_locpres)
	1		.or. (status.eq.cli$_present)) then
		      input_list(input_item).attributes =
	1	        lnm$m_terminal.or.input_list(input_item).attributes
		else if( (status.eq.cli$_locneg) .or.
	1		 (status.eq.cli$_negated) ) then
		      input_list(input_item).attributes =
	1	        (.not.lnm$m_terminal).and.
	2		input_list(input_item).attributes
		endif ! terminal_present
	      endif ! translation value present
	    endif ! translation qualifier present
	  endif ! p2 list element present
	enddo
c
	input_count = input_item

d	type *,'Input Count:',input_count
c
c Grab the process privilege mask in case locks and/or access mode are an issue
c
	jpi_list(1).item_code = jpi$_curpriv
	jpi_list(1).buffer_address = %loc(current_privileges)
	jpi_list(1).buffer_length = 4
	jpi_list(1).return_length_address = 0

	jpi_list(2).item_code = jpi$_authpriv
	jpi_list(2).buffer_address = %loc(authorized_privileges)
	jpi_list(2).buffer_length = 4
	jpi_list(2).return_length_address = 0

	jpi_list(3).item_code = jpi$_imagpriv
	jpi_list(3).buffer_address = %loc(image_privileges)
	jpi_list(3).buffer_length = 4
	jpi_list(3).return_length_address = 0

	jpi_list(4).item_code = jpi$_procpriv
	jpi_list(4).buffer_address = %loc(process_privileges)
	jpi_list(4).buffer_length = 4
	jpi_list(4).return_length_address = 0

	jpi_list(5).end_list = 0
	status = sys$getjpi(,,,jpi_list,,,)

d	type 990,'Process_Privileges: ',Process_privileges
d	type 990,'Current_Privileges: ',Current_privileges
d	type 990,'Authorized_Privileges: ',Authorized_privileges
d	type 990,'Image_Privileges: ',Image_privileges
c
c If the current process has sufficient privileges or the image has
c sufficient privileges to do this, then for each table (input and output)
c determine the actual table name and its parent table.
c   For either one, if they are a shared logical name table
c take a lock out on the table and the search list logical name being
c worked on before translating it.
c
c For current releases of VAX/VMS a shared logical name table is any child
c logical name table of LNM$SYSTEM_DIRECTORY.  All lnt's are children of
c either LNM$PROCESS_DIRECTORY(private) or LNM$SYSTEM_DIRECTORY(shared)
c
c Check the input table name first
c
	if( input_tlen.gt.0 ) then
	   status = lnm_table_find(input_table_name, input_table_len,
	1		input_table_parent, input_table_parent_len,
	2		logical_name(:lnm_len), input_table(:input_tlen),
	3		lnt$m_read,input_access_mode)
	   if( status.ne.ss$_normal ) call exit(status)
c
c If the table is a shared table then take out a lock on it and the
c search list logical name being worked on.
c
	   if( (input_table_len.gt.0) .and.
	1       (input_table_parent(:input_table_parent_len).ne.
	2	'LNM$PROCESS_DIRECTORY') )
	3     call lock_it( 1,input_table_name(:input_table_len),
	4		      logical_name(:lnm_len) )
	endif
c
c Check the output table next.  If the output table is the same as the
c input table, then don't do anything more to lock it -- the work done for
c the input table will suffice.
c
	if( output_table(:output_tlen).ne.input_table(:input_tlen)) then
	   status = lnm_table_find(output_table_name, output_table_len,
	1		output_table_parent, output_table_parent_len,
	2		logical_name(:lnm_len), output_table(:output_tlen),
	3		lnt$m_write,output_access_mode)
	   if( status.ne.ss$_normal ) call exit(status)
c
c If the table is a shared table then take out a lock on it and the
c search list logical name being worked on.
c
	   if( output_table_parent(:output_table_parent_len).ne.
	1	'LNM$PROCESS_DIRECTORY' )
	1    call lock_it( 2,output_table_name(:output_table_len),
	2		   logical_name(:lnm_len) )
	endif
c
c Determine if the logical name exists, and
c determine the maximum index of the logical name
c
	lnm_list(1).item_code = lnm$_max_index
	lnm_list(1).buffer_length = 4
	lnm_list(1).buffer_address = %loc(initial_index)
	lnm_list(1).return_length_address = 0
	lnm_list(2).item_code = lnm$_attributes
	lnm_list(2).buffer_length = 4
	lnm_list(2).buffer_address = %loc(input_attributes)
	lnm_list(2).return_length_address = 0
	lnm_list(3).end_list = 0
c
c If there was an input table name specified then use it.  Otherwise
c allow translation via normal translation search list.
c
	if( input_tlen.le.0 ) then
		input_tlen = 12
		input_table(1:input_tlen) = 'LNM$FILE_DEV'
	endif
	if( input_access_mode.le.psl$c_user) then
	  status = sys$trnlnm(,input_table(:input_tlen),
	1	logical_name(:lnm_len),input_access_mode,lnm_list)
	else
	  status = sys$trnlnm(,input_table(:input_tlen),
	1	logical_name(:lnm_len),,lnm_list)
	endif ! access mode specified for input ?
d	type *,'Translate:',status,', Attributes:',input_attributes
c
c If the logical name exists, then translate it.
c
	if( (status.eq.ss$_normal)
	1	.and. (initial_index.ge.0) ) then ! the logical name exists
c
c Build the item list to retrieve all of the equivalence strings and
c attributes.
c
	translation_count = 1+initial_index
	do indx = 0,initial_index
c
c For a search list we have to tell it each index that we want retrieved
c
		index_table(1+indx) = indx
		lnm_list(1+indx*gnum).item_code = lnm$_index
		lnm_list(1+indx*gnum).buffer_length = 4
		lnm_list(1+indx*gnum).buffer_address = %loc(index_table(1+indx))
		lnm_list(1+indx*gnum).return_length_address = 0
c
c We want the string and its associated length
c
		lnm_list(2+indx*gnum).item_code = lnm$_string
		lnm_list(2+indx*gnum).buffer_length =
	1		len(translation(1).name_string)
		lnm_list(2+indx*gnum).buffer_address =
	1		%loc(translation(1+indx).name_string)
		lnm_list(2+indx*gnum).return_length_address =
	1		%loc(translation(1+indx).name_length)
c
c We want to preserve any existing attributes associated with
c each equivalence string.
c
		lnm_list(3+indx*gnum).item_code = lnm$_attributes
		lnm_list(3+indx*gnum).buffer_length = 4
		lnm_list(3+indx*gnum).buffer_address =
	1		%loc(translation(1+indx).attributes)
		lnm_list(3+indx*gnum).return_length_address = 0
c
	enddo	! build translation parameter item list
c
c Tack on the end marker
c
	list_end = 1+gnum*translation_count
	lnm_list(list_end).end_list = 0
c
c Acquire all of the equivalence names and attributes.  Again, differentiate
c calls based on whether or not a specific name table was requested.
c
	  if( input_access_mode.le.psl$c_user) then
		status = sys$trnlnm(,input_table(:input_tlen),
	1		logical_name(:lnm_len),input_access_mode,lnm_list)
	  else
		status = sys$trnlnm(,input_table(:input_tlen),
	1		logical_name(:lnm_len),,lnm_list)
	  endif ! input_tlen >0
	else
c
C The name doesn't exist?
c
d		type *,'TRNLNM STATUS:',status
		if( status .ne.SS$_NOLOGNAM) then
			call exit(status)
		endif
	endif ! logical name exists
c
c Preserve input logical name attributes (unless specifically overridden)
c
	name_attributes = input_attributes.and.
	1	(lnm$m_confine.or.lnm$m_no_alias)
c
c Determine if any name attributes are present on the command.  If so, read
c in all of the values and build a mask of them.
c
	status = cli_present('NAME_ATTRIBUTES')
	if( 	status.eq.cli$_present
	1	.or.status.eq.cli$_concat
	2	.or.status.eq.cli$_comma
	3	.or.status.eq.cli$_locpres) then
	   status = cli_get_value('NAME_ATTRIBUTES',cmd_item,cmd_len)
	   if( status.ne.cli$_absent) then
c
c Check for CONFINE
c
	        status = cli_present('NAME_ATTRIBUTES.CONFINE')
d		type *,'NAME_attributes.Confine:',status
		if((status.eq.cli$_locpres).or.(status.eq.cli$_present)) then
		  name_attributes = lnm$m_confine.or.name_attributes
		else if( (status.eq.cli$_locneg) .or.
	1		 (status.eq.cli$_negated) )  then
		  name_attributes = (.not.lnm$m_confine).and.name_attributes
		endif ! confine_present
c
c Check for NO_ALIAS
c
		status = cli_present('NAME_ATTRIBUTES.NO_ALIAS')
d		type *,'Name_attributes.No_Alias:',status
		if((status.eq.cli$_locpres).or.(status.eq.cli$_present)) then
		  name_attributes = lnm$m_no_alias.or.name_attributes
		else if( (status.eq.cli$_locneg) .or.
	1		 (status.eq.cli$_negated) ) then
		  name_attributes = (.not.lnm$m_no_alias).and.name_attributes
		endif ! no_alias_present
	   endif ! NAME value present
	endif ! NAME qualifier present
d	type *,'Name_Attributes:',name_attributes
c
d	type *, 'Preparing Item List'
c
c Now what?
c
c Are we inserting or removing?  If insert_flag is false, then it is a
c DELETE of one kind or other
c
c If we are inserting -- get the input list and adjust the list to make it
c fit in.
c
c Determine whether or not we will use chaining to do it or just append
c to the list.  Arrange all of the pointers and then do the work.
c
	if( insert_flag ) then	! we are inserting/appending/prepending
	  if( before_flag ) then	! before something
	    if( before_index.gt.translation_count) then	! before the end of it
c
c Same as /AFTER
c
	      move_index = translation_count
	    else
c
c Determine indices to move, etc.
c
	      if( before_index.lt.1) then	! before the beginning
	        move_index = 0
	      else
	        move_index = before_index-1	! somewhere in the middle
	      endif ! where to move
	    endif ! before_index > max_index
	  else ! we're inserting after something 
c
c It's after something
c
	    if( after_index.gt.initial_index) then	! past the end
c
c The value is too big, so it goes at the end
c
	      move_index = translation_count
	    else ! after_index < max_index
c
c It is somewhere in the front,middle or maybe at the end
c
	      if( after_index.ge.0) then
	        move_index = after_index
	      else ! after all
c
c It goes at the end
c
	        move_index = translation_count
	      endif ! after_index >= 0
	    endif ! after_index < max_index
	  endif ! before or after
c
c Now process the lists
c
d	type *, 'Translation_count:',translation_count
d	type *, 'Move_index:',move_index
d	type *, 'Input_count:',input_count
c
	if( translation_count.gt.0 ) then ! there was a translation
	  if( move_index.gt.0 ) then ! Does it go in the middle?
	    call build_item_list (Translation,Lnm_List,Move_Index)
	  endif
c
c Insert the new item(s)
c
	  call build_item_list (Input_List,
	1	Lnm_List(2*Move_Index+1),input_count)
c
c Finish off with any remaining item(s) from the original translation
c
	  if( move_index.lt.translation_count) then
	    call build_item_list (Translation(Move_Index+1),
	1	Lnm_List(2*Move_Index+2*input_count+1),
	2	Translation_count-Move_Index)
	  endif ! move_index < translation_count
	else ! no translation existed
	  call build_item_list (Input_List(1),Lnm_List(1),input_count)
	endif ! translation test
	output_item = 2
	else ! delete/insert ?
c
c We are deleting:  get to the proper index and start eliminating
c things from the list.
c
c Is it a list of items or is it a bounded by name delete?
c
	status = cli_present('ITEM')
	if( status.ne.cli$_absent ) then	! ITEM present
c
c Get the list of item number(s)
c
	  input_count = 0
	  do while(	status.eq.cli$_present
	1	.or.status.eq.cli$_concat
	2	.or.status.eq.cli$_comma)
		status = cli_get_value('ITEM',cmd_item,cmd_len)
		if( status.ne.cli$_absent) then
d		  type *,'item:'//cmd_item(:cmd_len)
d		  type *,'status:',status
		  if( cmd_len.gt.0) then	! we have a value
c
c see if we have a * or number, or number1-number2
c
		    if( cmd_item(:cmd_len).eq.'*') then	! wildcarded = all
			delete_all = .TRUE.
		    else	! something other than *
		      if ( .not. DELETE_ALL ) then ! specific ones make sense
			hyphen_loc = index(cmd_item(:cmd_len),'-')
			if( hyphen_loc .ne. 0 ) then
c
c it's a pair of values, get the pair and fill in between
c special combinations: -m,n-,m-*,*-m
c
			if( hyphen_loc .eq. 1 ) then	! n1 = null
			  delete_start = 1	! null sets start to 1
			else	! it is not null
			  if( cmd_item(1:hyphen_loc-1) .eq. '*') then
			    delete_start = 1	! wild card = 1
			  else	! it must be a number
		    		p2_status = 
	1			ots$cvt_ti_l(cmd_item(:hyphen_loc-1), 
	2				delete_start)
		    		if(p2_status.ne.ss$_normal) call exit(p2_status)
			  endif ! n1 number 
			endif	! n1 not null
			if( hyphen_loc .eq. cmd_len ) then	! n2 = null
			   delete_end = translation_count
			else	! n2 not null
			   if( cmd_item(hyphen_loc+1:cmd_len).eq.'*') then
			     delete_end = translation_count	! n2 = to end
			   else	! n2 is a number
		    		p2_status = 
	1			ots$cvt_ti_l(cmd_item(hyphen_loc+1:cmd_len), 
	2				delete_end)
		    		if(p2_status.ne.ss$_normal) call exit(p2_status)
			   endif! n2 star/number
			endif	! n2 null/value
			if( delete_end.gt.translation_count) 
	1			delete_end = translation_count
c
c fill the table with the list
c
			do item_id = delete_start,delete_end
				input_count = 1+input_count
				index_table(input_count) = item_id
			enddo
			else	! no hyphen, single number
		
			  input_count = 1+input_count
			  p2_status = ots$cvt_ti_l(cmd_item(:cmd_len),
	1			index_table(input_count))
			  if(p2_status.ne.ss$_normal) call exit(p2_status)
		        endif	! hyphen
		      endif	! specific deletes make sense (no delete_all)
		    endif	! * or something else
		  endif	! cmd_len > 0 => we have a value
		endif	! next good item
	  enddo	! ITEM qualifier present
	  item_flag = input_count.gt.0
	  if( item_flag ) then	! items were supplied
		input_item = 1
		move_index = index_table(input_item)
d		type *,'Input_item:',input_item
d		type *,'Move_index:',Move_index
	  endif	! items were supplied
c 
c Otherwise we're deleting based on matching equivalence names supplied
c with the command.
c
c ITEM was not specified
c Are we deleting from the beginning or the middle/end?
c
c
c If the count is 0 and /DELETE has been specified then assume /DELETE=ALL
c if /ITEM was not specified
c
	else if( input_count .eq. 0 .and. .not. insert_flag ) then
		delete_all = .TRUE.
	else if( before_flag ) then
	  if( before_index.gt.translation_count ) then
		move_index = translation_count
	  else
	    if( before_index.lt.1 ) then
	      move_index = 1
	    else
	      move_index = before_index-1
	    endif ! before_index > 1
	  endif ! before_index > translation_count
	else ! after_flag
	  if( after_index.gt. translation_count ) then
	    move_index = translation_count-1
	  else ! after_index < initial_index
	    if( after_index .lt. 0 ) then
	      move_index = translation_count-1
	    else ! after_index > 0
	      move_index = after_index
	    endif ! after_index >0
	  endif ! after_index < translation_count
	endif ! before/after
	end_index = move_index + input_count
	if( end_index .gt. translation_count ) end_index = translation_count
d	type *,'Move_Index:',move_index,', End_Index:',end_index
c
c What is this next block doing?  Fill in here when I remember
c
c
	if( move_index.gt.1 ) then
	  call build_item_list( Translation, Lnm_List, move_index-1)
	  if( end_index.lt. initial_index) then
	    call build_item_list( translation(end_index),
	1	lnm_list(2*move_index-1), translation_count-end_index+1)
	  endif ! move_index < initial_index
	else ! move_index < 1
	  call build_item_list( Translation(end_index), lnm_list,
	1	translation_count-end_index+1 )
	endif ! move_index > 1
	
	if( delete_all ) then	! don't look at 'em, wipe 'em all!! ;-)
		output_item = 0
	else	! process the items specified
c
c Search for the input items and remove them in order from the list.
c If not found before finishing the translation list, the remaining ones
c are not checked.
c
	input_item = 1
	output_item = 1
	do lnm_index = 1, translation_count
c
c Does the current item on the translation list = the head of the input list?
c
	  if(item_flag .and. ( move_index.eq.lnm_index ) ) then
c
c If working from item list numbers then update the pointer
c
		input_item = 1+input_item
		if( input_item.le.input_count ) then
			move_index = index_table(input_item)
		else
			move_index = translation_count+1
		endif
d		type *,'Input_item:',input_item
d		type *,'Move_index:',move_index
	  else if( .not.item_flag .and.
	1   (lnm_index.ge.move_index .and.
	1   translation(lnm_index).name_string(
	2     :translation(lnm_index).name_length).eq.
	3   input_list(input_item).name_string(
	4     :input_list(input_item).name_length))
	5   ) then
d		type *, 'Matched input:',input_item,' with translation:',
d	1		lnm_index
		input_item = 1+input_item
	  else ! copy the element from the translation list
c
c For each equivalence name generate 2 entries in the item list.
c The 1st entry is for the translation attributes.  The 2nd entry
c is for the string.
c
	    lnm_list(output_item).item_code = lnm$_attributes
	    lnm_list(output_item).buffer_length = 4
c
c Force equivalence name attributes to be limited to only those that
c apply directly to equivalence names.  Currently these are only the
c 2 translation attributes.
c
	    translation(lnm_index).attributes =
	1	(lnm$m_concealed.or.lnm$m_terminal)
	2	.and. translation(lnm_index).attributes
	    lnm_list(output_item).buffer_address =
	1	%loc(translation(lnm_index).attributes)
	    Lnm_List(output_item).return_length_address = 0
c
c Put in the entry for the equivalence name string
c
	    output_item = 1+output_item
	    Lnm_List(output_item).item_code = lnm$_string
	    Lnm_List(output_item).buffer_length =
	1	translation(lnm_index).name_length
	    Lnm_List(output_item).buffer_address =
	1	%loc(translation(lnm_index).name_string)
	    Lnm_List(output_item).return_length_address = 0
	    output_item = 1+output_item
	  endif
	end do
c
c Terminate the item list
c
	lnm_list(output_item).end_list = 0
c
c
	endif ! process specified items for delete
	endif ! insert/delete
c
c Then call the  sys$crelnm routine to put the new definition out.
c If the new list is empty, then delete the logical name.
c
d	type *,'Output_item:',output_item
	if( output_item.gt.1 ) then ! There is a new definition
c
c
c During the development I was limited to working on a system without
c privileges, so I didn't really test out the ideas listed below.
c Eventually, I would like to have the image coded and tested for
c safety when it might be installed with privileges.  Currently
c I would only recommend that you install it with SYSLCK privilege.
c
c If the image is installed with privileges, but the user doesn't have
c SYSNAM or GRPNAM or some other relevant privilege, then it may be
c important to add code in here to make sure that the current privileges
c are no greater than the ones held by the user outside of the image.
c The only legitimate privilege to keep if the image is installed with it
c is the SYSLCK privilege -- there is no real risk in using SYSLCK since
c the only conflict will be with other users of SLMOD or other utilities
c that might use the same locks as SLMOD.
c
c
c The meta-code for the privs check might look like this:
c
c  Does the image have privs to affect system or group logical names ?
c  If so, does the user have elevated privs ?  Intersect the user's
c  privs with the image privs.
c
c  Does the image/user have SYSLCK? If so, make sure that stays on.
c  Set current privs to the appropriate ones.
c  Perform the $CRELNM or $DELLNM.
c  Restore privs to what they were.
c
c If an access mode was specified, then use it.  Otherwise use the
c default of none -- which is USER
c
c If an access mode was specified, then use it.  Otherwise use the
c default of none -- which is USER
c
	  if( output_access_mode.le.psl$c_user ) then
c
c verify that the user has privs to access the mode they are asking for
c
c
c Decide between call to  $crelnm and lib$set_logical
c
	    if( output_access_mode.eq.psl$c_user) then
		create_mode = 1
	    else if( output_access_mode.eq.psl$c_super ) then
		create_mode = 2
	    else
c
c Does the user have sufficient privileges to do the inner access mode
c requested?  If not, use supervisor mode instead.
c
		if( (current_privileges.and.
	1		(prv$m_cmexec.or.prv$m_cmkrnl)).eq.0 ) then
		  create_mode = 2
		  output_access_mode = psl$c_super
		else
		  create_mode = 1
		endif
	    endif ! mode tests
d	type *,'Create_Mode:',create_mode
	    if( create_mode.eq.1) then
		status = sys$crelnm(name_attributes,output_table(:output_tlen),
	1		logical_name(:lnm_len),output_access_mode,lnm_list)
	    else
		status = lib$set_logical(logical_name(:lnm_len),,
	1		output_table(:output_tlen),name_attributes,lnm_list)
	    endif ! create mode compare
	  else ! output access mode not specified
	    status = sys$crelnm(name_attributes,output_table(:output_tlen),
	1		logical_name(:lnm_len),,lnm_list)
	  endif
	  exit_status = status

	 if( (exit_status.and.1) .ne. 0 ) then
c
c Post processing
c
	  if( log_flag) then
	    p2_status = lib$put_output(
	1     'SLMOD-I-UPDATED, DEFINED/UPDATED logical name '
	2     //logical_name(:lnm_len))
	  endif

	  if( cli_present('SYMBOL').ne.cli$_absent) then
	    status = cli_get_value('SYMBOL',symbol_name,sym_len)
	    sym_ptr = 1
	    sym_ctr = 1
	    do while( ( lnm_list(sym_ctr).item_code.ne.0) .and.
	1	(sym_ptr.lt.1024) )
		sym_ctr = 1+sym_ctr
	        cmd_len = lnm_list(sym_ctr).buffer_length
d		type *,'cmd_len:',cmd_len,
d	1		', sym_ptr:',sym_ptr,',sym_ctr:',sym_ctr
		if( sym_ctr.lt.3 ) then
		  status = str$copy_r(symbol_buffer(sym_ptr:sym_ptr+cmd_len-1),
	1		cmd_len, %val(lnm_list(sym_ctr).buffer_address))
		  sym_ptr = 1+cmd_len
		else
		  symbol_buffer(sym_ptr:sym_ptr) = ','
		  sym_ptr = 1+sym_ptr
		  status = str$copy_r(symbol_buffer(sym_ptr:sym_ptr+cmd_len-1),
	1		cmd_len,%val(lnm_list(sym_ctr).buffer_address))
		  sym_ptr = sym_ptr+cmd_len
		endif
		tran_attrib =
	1		dereference(%val(lnm_list(sym_ctr-1).buffer_address))
d		type 990,'Tran_attrib: ',tran_attrib
990		format(1X,A,Z8)
		if( tran_attrib.ne.0) then
		  tran_string = '/TRANSLATION=('
		  tran_len = 14
		  if( (tran_attrib.and.lnm$m_concealed).ne.0 ) then
			tran_string(tran_len+1:tran_len+9) = 'CONCEALED'
			tran_len = tran_len+9
			if( (tran_attrib.and. lnm$m_terminal).ne.0 ) then
			   tran_string(tran_len+1:tran_len+9) = ',TERMINAL'
		  	   tran_len = tran_len+9
			endif
		  else
			if( (tran_attrib.and. lnm$m_terminal).ne.0 ) then
			   tran_string(tran_len+1:tran_len+8) = 'TERMINAL'
		  	   tran_len = tran_len+8
			endif
		  endif
		  tran_string(1+tran_len:1+tran_len) = ')'
		  tran_len = 1+tran_len
		  symbol_buffer(sym_ptr:sym_ptr+tran_len) =
	1		tran_string(1:tran_len)
		  sym_ptr = sym_ptr+tran_len
		endif
		sym_ctr = 1+sym_ctr
d	      type *,'sym_ptr:',sym_ptr
d	      type *,'symbol_buffer:'//symbol_buffer(:sym_ptr-1)
	    enddo
c
c Add NAME_ATTRIBUTES on the end of the whole string
c
	    if( name_attributes.ne.0) then	! there are attributes
		  tran_string = '/NAME=('
		  tran_len = 7
		  if( (name_attributes.and.lnm$m_CONFINE).ne.0 ) then
			tran_string(tran_len+1:tran_len+7) = 'CONFINE'
			tran_len = tran_len+7
			if( (name_attributes.and. lnm$m_no_alias).ne.0 ) then
			   tran_string(tran_len+1:tran_len+9) = ',NO_ALIAS'
		  	   tran_len = tran_len+9
			endif
		  else	! Confine not specified
			if( (name_attributes.and. lnm$m_no_alias).ne.0 ) then
			   tran_string(tran_len+1:tran_len+8) = 'NO_ALIAS'
		  	   tran_len = tran_len+8
			endif
		  endif	! confine specified
		  tran_string(1+tran_len:1+tran_len) = ')'
		  tran_len = 1+tran_len
		  symbol_buffer(sym_ptr:sym_ptr+tran_len) =
	1		tran_string(1:tran_len)
		  sym_ptr = sym_ptr+tran_len
	  endif	! Name_Attributes supplied
c
c Handle output access mode
c
	  if( output_access_mode.le.psl$c_user ) then
		if( output_access_mode.eq.psl$c_user ) then
		  tran_len = 10
		  tran_string(1:tran_len) = '/USER_MODE'
		else if( output_access_mode.eq.psl$c_super ) then
		  tran_len = 16
		  tran_string(:tran_len) = '/SUPERVISOR_MODE'
		else if( output_access_mode.eq.psl$c_exec ) then
		  tran_len = 15
		  tran_string(:tran_len) = '/EXECUTIVE_MODE'
		else
		  tran_len = 12
		  tran_string(:tran_len) = '/KERNEL_MODE'
	  	endif
		symbol_buffer(sym_ptr:sym_ptr+tran_len) =
	1		tran_string(1:tran_len)
		sym_ptr = sym_ptr+tran_len
	  endif
c
c  Set the DCL symbol to the appropriate value
c
	    if( sym_ptr.gt.1024 ) sym_ptr = 1024
d	    type *,'sym_ptr:',sym_ptr
d	    type *,'symbol_buffer:'//symbol_buffer(:sym_ptr-1)
	    status = lib$set_symbol(symbol_name(:sym_len),
	1		 symbol_buffer(:sym_ptr-1))
	  endif
	 endif ! status normal test
c
c Code to DELETE the search list logical name
c
	else ! the name is to be deleted if ok
	  if(ok_to_delete) then
d	type *,'Deleting '//logical_name(:lnm_len)//' with '
d	1	//'with access mode:',output_access_mode
c
c Check access mode -- Use lib$delete_logical for supervisor mode
c
	    if( output_access_mode.eq.psl$c_super ) then
		status = lib$delete_logical(logical_name(:lnm_len),
	1		output_table(:output_tlen))
		exit_status = status
	    else if( output_access_mode.le.psl$c_user ) then
	      status = sys$dellnm(output_table(:output_tlen),
	1	logical_name(:lnm_len),output_access_mode)
	      exit_status = status
	    else ! no access mode specified
	      status = sys$dellnm(output_table(:output_tlen),
	1	logical_name(:lnm_len),)
	      exit_status = status
	    endif ! access mode is specified
	    if( ((exit_status.and.1).ne.0 ) .and. log_flag) then
	      p2_status = lib$put_output(
	1       'SLMOD-I-DELETED, logical name '//logical_name(:lnm_len))
	    endif
	  else
	    if( log_flag) then
	      p2_status = lib$put_output(
	1     'SLMOD-I-DELIGNORED, logical name '//logical_name(:lnm_len)//
	2     '-- /NOEMPTY_DELETE specified')
	    endif
	  endif ! ok_to_delete
	  if( cli_present('SYMBOL').ne.cli$_absent) then
	      status = cli_get_value('SYMBOL',symbol_name,sym_len)
	      status = lib$delete_symbol(symbol_name(:sym_len))
	  endif
	endif ! name to be deleted
c
c If Log is specified then note the update
c To do this properly, call lib$put_output
c
c
c If the current process has sufficient privileges or the image has
c sufficient privileges to do this, then release the locks on the
c logical name search list before translating it.
c
	if( input_tlen.gt.0 ) then
	  if( input_table(:input_tlen).ne.'LNM$PROCESS' )
	1     call unlock_it( 1,input_table(:input_tlen),
	2			logical_name(:lnm_len) )
	endif
	if( output_table(:output_tlen).ne.input_table(:input_tlen)) then
	  if( output_table(:output_tlen).ne.'LNM$PROCESS' )
	1     call unlock_it( 2,output_table(:output_tlen),
	2			logical_name(:lnm_len) )
	endif
c
c Leave the image
c
	call exit(exit_status)
	end ! Program SLMOD