	PROGRAM NETMAIL
	IMPLICIT INTEGER(A-Z)
	INTEGER*4 icode
	CHARACTER running_user*31, original_user*31, cmd_type*6
	CHARACTER*256 options(4)
	LOGICAL updating
	COMMON original_user
	COMMON updating
	PARAMETER (LIB$M_CLI_CTRLY = '02000000'X)
C
C	Display version number.
C
	CALL LIB$PUT_OUTPUT(' ')
	CALL LIB$PUT_OUTPUT('Netmail Version 1.0  17-Jan-1986')
	CALL LIB$PUT_OUTPUT(' ')
C
C	Disable CTRL-Y.
C
	icode = LIB$DISABLE_CTRL(lib$m_cli_ctrly)
	if (.not.icode) CALL LIB$STOP(%val(icode))
C
C	Get the running user's account.
C
	CALL GET_USERNAME(running_user)
	original_user = running_user
C
C	Setup Break Traps.
C
	CALL SETTRAP
C
C	Get command wanted.
C
	CALL GETCMD(cmd_type,options)
C
C	Setup EXIT handler.
C
	CALL SETEXIT
C
C	Set username to NETMAIL for access to VMSMAIL file via proxy.
C
	CALL SET_USER('NETMAIL')
C
C	If SHOW option selected, go show what user wanted.
C
	If((cmd_type.eq.'SHOW').or.(cmd_type.eq.'LIST'))
     +    CALL SHOWINFO(running_user,cmd_type,options)
C
C	If SET/DELETE option selected, go set what user wanted.
C
	If((cmd_type.eq.'SET').or.(cmd_type.eq.'DELETE')) then
	updating = .true.
	CALL SETINFO(running_user,cmd_type,options)
	Endif
C
C	Reset username to original and enable CTRL-Y.
C
	CALL SET_USER(original_user)
	icode = LIB$ENABLE_CTRL(lib$m_cli_ctrly)
	if (.not.icode) CALL LIB$STOP(%val(icode))
C
	end
	SUBROUTINE GET_USERNAME(running_user)
	IMPLICIT INTEGER(A-Z)
	INTEGER*4 icode
	CHARACTER running_user*31
	INCLUDE '($LIBDEF)'
	INCLUDE '($JPIDEF)'
	EXTERNAL netmail_nousername
C
C	Set default strings and logicals.
C
	running_user = ' '
C
C	Get running username.
C
	icode = LIB$GETJPI(JPI$_USERNAME,,,, running_user,)
C
	return
	end
	SUBROUTINE GET_MAIL_NODE(mail_node, local_node, number_mail_nodes)
	IMPLICIT INTEGER(A-Z)
	INTEGER*4 icode, mail_len, number_mail_nodes, mail_index
	INTEGER*4 trnlst_l(16), SYS$TRNLNM, mail_table_len
	INTEGER*2 trnlst(32)
C
	CHARACTER mail_node(127)*31, local_node*31
	CHARACTER mail_name*255, mail_table*31
C	CHARACTER*16 table_name /'LNM$SYSTEM_TABLE'/
	CHARACTER*17 table_name /'LNM$PROCESS_TABLE'/
	LOGICAL get_logical
	EQUIVALENCE (trnlst, trnlst_l)
	PARAMETER LNM$C_MAXDEPTH     = '0000000A'X
	PARAMETER LNM$C_NAMLENGTH    = '000000FF'X
	PARAMETER LNM$C_TABNAMLEN    = '0000001F'X
	PARAMETER LNM$M_CASE_BLIND   = '02000000'X
	PARAMETER LNM$M_CONCEALED    = '00000100'X
	PARAMETER LNM$M_CONFINE      = '00000002'X
	PARAMETER LNM$M_CREATE_IF    = '01000000'X
	PARAMETER LNM$M_CRELOG       = '00000004'X
	PARAMETER LNM$M_EXISTS       = '00000400'X
	PARAMETER LNM$M_NO_ALIAS     = '00000001'X
	PARAMETER LNM$M_SHAREABLE    = '00010000'X
	PARAMETER LNM$M_TABLE        = '00000008'X
	PARAMETER LNM$M_TERMINAL     = '00000200'X
	PARAMETER LNM$S_LNMDEF       = '00000004'X
	PARAMETER LNM$V_CASE_BLIND   = '00000019'X
	PARAMETER LNM$V_CONCEALED    = '00000008'X
	PARAMETER LNM$V_CONFINE      = '00000001'X
	PARAMETER LNM$V_CREATE_IF    = '00000018'X
	PARAMETER LNM$V_CRELOG       = '00000002'X
	PARAMETER LNM$V_EXISTS       = '0000000A'X
	PARAMETER LNM$V_NO_ALIAS     = '00000000'X
	PARAMETER LNM$V_SHAREABLE    = '00000010'X
	PARAMETER LNM$V_TABLE        = '00000003'X
	PARAMETER LNM$V_TERMINAL     = '00000009'X
	PARAMETER LNM$_ACMODE        = '00000006'X
	PARAMETER LNM$_ATTRIBUTES    = '00000003'X
	PARAMETER LNM$_CHAIN         = 'FFFFFFFF'X
	PARAMETER LNM$_INDEX         = '00000001'X
	PARAMETER LNM$_LENGTH        = '00000005'X
	PARAMETER LNM$_LNMB_ADDR     = '00000009'X
	PARAMETER LNM$_MAX_INDEX     = '00000007'X
	PARAMETER LNM$_PARENT        = '00000008'X
	PARAMETER LNM$_STRING        = '00000002'X
	PARAMETER LNM$_TABLE         = '00000004'X
C
	EXTERNAL netmail_nomailnode, netmail_nolocalnode
	INCLUDE '($LIBDEF)'
	INCLUDE '($SSDEF)'
C
C	Set up item list for TRNLNM system service.
C
C	Index item.
	mail_len     = 0
	trnlst(1)    = 4
	trnlst(2)    = LNM$_INDEX
	trnlst_l(2)  = %LOC(mail_index)
	trnlst_l(3)  = 0
C	Logical string item.
	trnlst(7)    = 255
	trnlst(8)    = LNM$_STRING
	trnlst_l(5)  = %LOC(mail_name)
	trnlst_l(6)  = 0
C	Length of logical.
	trnlst(13)   = 4
	trnlst(14)   = LNM$_LENGTH
	trnlst_l(8)  = %LOC(mail_len)
	trnlst_l(9)  = 0
C	Max number logicals in list.
	trnlst(19)   = 4
	trnlst(20)   = LNM$_MAX_INDEX
	trnlst_l(11) = %LOC(number_mail_nodes)
	trnlst_l(12) = 0
C	Max number logicals in list.
	trnlst(25)   = 31
	trnlst(26)   = LNM$_TABLE
	trnlst_l(14) = %LOC(mail_table)
	trnlst_l(15) = %LOC(mail_table_len)
	trnlst_l(16) = 0
C
C	Set default strings and logicals.
C
	get_logical = .true.
	mail_name = ' '
	local_node  = ' '
	DO 100 I = 1,127
	mail_node(I) = ' '
100	continue
C
C	Translate logical name NETMAIL.
C
	DO WHILE (get_logical)
	icode = SYS$TRNLNM(,table_name,'NETMAIL',,trnlst)
	mail_index = mail_index + 1
	  if (icode.eq.SS$_NOTRAN)
     &    CALL LIB$SIGNAL(netmail_nomailnode)
	icode = STR$UPCASE(mail_node(mail_index), mail_name)
	mail_name = ' '
	if (mail_index.gt.number_mail_nodes) get_logical = .false.
	Enddo ! End loop for mail node logical search.
C
C	Translate logical name SYS$NODE
C
	icode = LIB$SYS_TRNLOG('SYS$NODE',,local_node)
	 if(local_node(1:1).eq.'_') local_node = local_node(2:31)
	  if (icode.eq.SS$_NOTRAN)
     &    CALL LIB$SIGNAL(netmail_nolocalnode)
	icode = STR$UPCASE(local_node, local_node)
C
	return
	end
	SUBROUTINE GETCMD(cmd_type, options)
	IMPLICIT INTEGER (A-Z)

	INTEGER*4 str$trim, str$position, icode, for_len, option_len
	CHARACTER foreign_line*512, cmd_type*6, running_user*31
	CHARACTER*256 options(4)
	EXTERNAL netmailcli, netmail_badinput, netmail_noinput
C
        PARAMETER CLI$G_PRESENT   = '0003FD19'X
        PARAMETER CLI$L_PRESENT   = '0003FD31'X
        PARAMETER CLI$G_NEGATED   = '000381F8'X
        PARAMETER CLI$L_NEGATED   = '00038230'X
        PARAMETER CLI$_ABSENT     = '000381F0'X
C
C	Set default strings and logicals.
C
	foreign_line = ' '
	options(1)   = ' '
	options(2)   = ' '
	options(3)   = ' '
	options(4)   = ' '
	cmd_type     = ' '
	running_user = ' '
C
C	Get foreign command line.
C
	icode = LIB$GET_FOREIGN(foreign_line,'Netmail: ')
	icode = STR$TRIM(foreign_line, foreign_line, for_len)
	if (for_len.eq.0) CALL LIB$SIGNAL(netmail_noinput)
C
C	Let DCL parse it.
C
	icode = CLI$DCL_PARSE('netmail '//foreign_line(1:for_len),netmailcli)
C
C	Get Command type (SET/SHOW/DELETE/LIST). Default = SHOW.
C
	icode = cli$present('p1')
	if (icode) then
	icode = cli$get_value('p1', cmd_type)
	  if (cmd_type(1:2).eq.'SE') cmd_type = 'SET'
	  if (cmd_type(1:2).eq.'SH') cmd_type = 'SHOW'
	  if (cmd_type(1:2).eq.'DE') cmd_type = 'DELETE'
	  if (cmd_type(1:2).eq.'LI') cmd_type = 'LIST'
	else
	 cmd_type = 'SHOW'
	Endif !End of p1 (SET/SHOW/DELETE) check.
C
C	Get USERNAME input.
C
	icode = cli$present('USERNAME')
	if (icode) then
	icode = cli$get_value('USERNAME', options(1))
	icode = str$trim(options(1), options(1), option_len)
	if (option_len.lt.3) CALL LIB$SIGNAL(netmail_badinput)
	Endif !Username check.
C
C	Get NAME input.
C
	icode = cli$present('NAME')
	if (icode) then
	icode = cli$get_value('NAME', options(2))
	icode = str$trim(options(2), options(2), option_len)
	if (option_len.lt.3) call LIB$SIGNAL(netmail_badinput)
	Endif !Name check.
C
C	Get PERSONAL input.
C
	icode = cli$present('PERSONAL')
	if (icode) icode = cli$get_value('PERSONAL', options(3))
C
C	Get FORWARD node address.
C
	icode = cli$present('FORWARD')
	If (icode) then
	icode = cli$get_value('FORWARD', options(4))
	Else
	 If(icode.ne.229880) then
	 CALL GET_USERNAME(running_user)
	 options(4) = running_user
	 Endif
	Endif
C
	return
	end
	SUBROUTINE SHOWINFO(running_user, cmd_type, options)
	IMPLICIT INTEGER(A-Z)
C
C	SYS$SYSTEM:VMSMAIL.DAT record layout.
C
	CHARACTER  username*31	   !1:31   keyid=0
	BYTE	   mail_flags(2)   !32:33
	BYTE	   mail_count(2)   !34:35
	BYTE	   mail_spare(28)  !36:63
	BYTE	   mail_spare1(2)  !64:65
	BYTE	   dir_length	   !66:66
	BYTE	   per_length	   !67:67
	BYTE	   fwd_length	   !68:68
	CHARACTER  mail_data*639   !See below...
	CHARACTER  forward*256	   !69:69+fwd_length
	CHARACTER  personal*127	   !69:69+fwd_length+per_length
	CHARACTER  directory*256   !69:69+fwd_length+per_length+dir_length
C
C	End of VMSMAIL.DAT record layout.
C
	INTEGER*4 for_len, per_len, dir_len, name_len, mail_len, ios
	INTEGER*4 str$position, str$trim, str$match_wild, option_len
	INTEGER*4 number_nodes
	CHARACTER local_node*31, mail_node*31, hold_node(127)*31
	CHARACTER mail_file*128, name*256
	CHARACTER cmd_type*4, running_user*31, name_match*256
	CHARACTER*256 options(4)
	LOGICAL record_found, displayed_record, open_write, privl
	LOGICAL modified, new_record, updating
C
	COMMON updating
	INCLUDE '($LIBDEF)'
        PARAMETER (STR$_MATCH   = 2393113)
        PARAMETER (STR$_NOMATCH = 2392584)
	EXTERNAL netmail_mailfile, netmail_norecfnd
	EXTERNAL netmail_decnet
C
C	Set strings and logicals.
C
	displayed_record = .false.
	record_found     = .false.
	new_record       = .false.
	privl		 = .false.
	opened		 = .false.
	open_write	 = .false.
	modified 	 = .false.
	updating	 = .false.
	forward   = ' '
	personal  = ' '
	directory = ' '
	name      = ' '
	mail_node = ' '
C
C	Check to see if the user if priveleged.
C
	CALL CHKPRIVS(cmd_type, privl)
C
C	Set up input for wildcarding.
C
	icode = STR$TRIM(options(1), options(1), option_len)
	if (option_len.ne.0) then
	options(1) = '*' // options(1)(1:option_len) // '*'
	else
	icode = STR$TRIM(options(2), options(2), option_len)
	if (option_len.ne.0)
     +  options(2) = '*' // options(2)(1:option_len) // '*'
	Endif !Option check.
C
C	Get MAIL node and local node.
C
	CALL GET_MAIL_NODE(hold_node, local_node, number_nodes)
	icode = STR$TRIM(hold_node(1), hold_node(1), mail_len)
	mail_node = hold_node(1)(1:mail_len)
C
C	Go open mailfile.
C
	CALL OPENMAIL(mail_node, local_node, open_write, opened)
	if (.not.opened) CALL LIB$STOP
C
C	If LIST then output title.
C
	If (cmd_type.eq.'LIST') then
	CALL LIB$PUT_OUTPUT(' ')
	CALL LIB$PUT_OUTPUT('Listing NETMAIL database on '//mail_node)
	Endif
C
C	Get record.
C
100	read(unit=1,iostat=ios,err=200,END=500)
     +  username, (mail_flags(I),I=1,2), (mail_count(I),I=1,2),
     +  (mail_spare(I),I=1,28), (mail_spare1(I),I=1,2),
     +  dir_length, per_length, fwd_length, mail_data
C
200	CONTINUE
C
C	If the record matches, display it.
C
	record_found = .false.
	CALL DISPLAYREC(cmd_type, options, username, running_user,
     +              mail_data, fwd_length, per_length, modified,
     +              displayed_record, record_found, new_record, privl)
C
C	Go check another record incase there is additional matches.
C
	goto 100
C
C	If record not found, display message, then bug out.
C
500	continue
	CLOSE (UNIT=1)
	if (.not.displayed_record) then
	CALL LIB$SIGNAL(netmail_norecfnd)
	Endif
	CALL LIB$PUT_OUTPUT(' ')
	return
C
	end

	SUBROUTINE SETINFO(running_user, cmd_type, options)
	IMPLICIT INTEGER(A-Z)
C
C	SYS$SYSTEM:VMSMAIL.DAT record layout.
C
	CHARACTER  username*31	   !1:31   keyid=0
	BYTE	   mail_flags(2)   !32:33
	BYTE	   mail_count(2)   !34:35
	BYTE	   mail_spare(28)  !36:63
	BYTE	   mail_spare1(2)  !64:65
	BYTE	   dir_length	   !66:66
	BYTE	   per_length	   !67:67
	BYTE	   fwd_length	   !68:68
	CHARACTER  mail_data*639   !See below...
	CHARACTER  forward*256	   !69:69+fwd_length
	CHARACTER  personal*127	   !69:69+fwd_length+per_length
	CHARACTER  directory*256   !69:69+fwd_length+per_length+dir_length
C
C	End of VMSMAIL.DAT record layout.
C
	INTEGER*4 for_len, per_len, dir_len, name_len, mail_len, ios
	INTEGER*4 str$position, str$trim, str$match_wild, option_len
	INTEGER*4 number_nodes, data_len
	CHARACTER local_node*31, mail_node(127)*31, mail_file*40, name*256
	CHARACTER cmd_type*4, running_user*31, hold_node*31
	CHARACTER*256 options(4)
	LOGICAL record_found, mail_search, answer, displayed_record
	LOGICAL modified, new_record
C
	INCLUDE '($LIBDEF)'
        PARAMETER (FOR$_NORECORD = 36)
        PARAMETER (STR$_MATCH    = 2393113)
        PARAMETER (STR$_NOMATCH  = 2392584)
	EXTERNAL netmail_norecord, netmail_decnet, netmail_update
	EXTERNAL netmail_delete
C
C	Set strings and logicals.
C
	forward   = ' '
	personal  = ' '
	directory = ' '
	name      = ' '
	hold_node = ' '
	answer       = .false.
	mail_search  = .true.
	new_record   = .false.
	open	     = .false.
	open_write   = .true.
	privl        = .false.
	record_found = .false.
C
C	Check to see if the user if priveleged if /USER was specified.
C
	icode = STR$TRIM(options(1), options(1), option_len)
	if (option_len.ne.0) then
	 if(options(1)(1:31).ne.running_user) CALL CHKPRIVS(cmd_type,privl)
	if (privl) running_user = options(1)(1:31)
	Endif
C
C	Get MAIL node and local node.
C
	CALL GET_MAIL_NODE(mail_node, local_node, number_nodes, search)
C
C	Open the mail file for update.
C
	mail_index = 1
	DO WHILE (mail_search)
	CALL OPENMAIL(mail_node(mail_index),local_node, open_write, opened)
	if (.not.opened) then
	goto 600
	Endif !Skip to index mail_node because file was not opened.
C
C	Get record.
C
100	read(unit=1,iostat=ios,err=200,key=running_user,keyid=0)
     +  username, (mail_flags(I),I=1,2), (mail_count(I),I=1,2),
     +  (mail_spare(I),I=1,28), (mail_spare1(I),I=1,2),
     +  dir_length, per_length, fwd_length, mail_data
C
200	CONTINUE
	if(ios.eq.FOR$_NORECORD) then
	CALL LIB$SIGNAL(netmail_norecord)
	record_found = .false.
	new_record = .true.
	Else
	record_found = .true.
	Endif !Record check.
C
C	Output record.
C
	if((record_found).and.(mail_index.eq.1))
     +  CALL DISPLAYREC(cmd_type, options, username, running_user,
     +             mail_data, fwd_length, per_length, modified,
     +             displayed_record, record_found, new_record, privl)
C
C	Make/change new record and display it.
C
	hold_node = mail_node(mail_index)
	if(cmd_type.eq.'SET') then
	CALL UPDATE(options, username, mail_data, fwd_length, per_length,
     +              dir_length, privl, hold_node, local_node)
	modified   = .true.
	If (mail_index.eq.1)
     +  CALL DISPLAYREC(cmd_type, options, username, running_user,
     +             mail_data, fwd_length, per_length, modified,
     +             displayed_record, record_found, new_record, privl)
	Endif !Set/DELETE check.
C
C	Go ask if the changes are ok to make.
C
	If (mail_index.eq.1)
     +     CALL VERIFYUPD(cmd_type, record_found, answer)
C
C	Go update the record.
C
	  icode = STR$TRIM(mail_node(mail_index),
     +                     mail_node(mail_index), mail_len)
	  If (cmd_type.eq.'SET') then
	   icode = STR$TRIM(mail_data, mail_data, data_len)
	   If (record_found) then
	   rewrite(1)
     +        username, (mail_flags(I),I=1,2), (mail_count(I),I=1,2),
     +        (mail_spare(I),I=1,28), (mail_spare1(I),I=1,2),
     +        dir_length, per_length, fwd_length, mail_data(1:data_len)
	   CALL LIB$SIGNAL(netmail_update,%val(1),hold_node(1:mail_len-2))
	   close(unit=1)
	   Else !It is a new record.
	   write(1)
     +        username, (mail_flags(I),I=1,2), (mail_count(I),I=1,2),
     +        (mail_spare(I),I=1,28), (mail_spare1(I),I=1,2),
     +        dir_length, per_length, fwd_length, mail_data(1:data_len)
	   CALL LIB$SIGNAL(netmail_update,%val(1),hold_node(1:mail_len))
	   close(unit=1)
	   Endif !Update record.
	  Else !The request is to DELETE the record.
	   DELETE(1)
	   CALL LIB$SIGNAL(netmail_delete,%val(1),hold_node(1:mail_len))
	  close(unit=1)
	  Endif !SET/DELETE record.
C
600	continue
	mail_index = mail_index + 1
	if (mail_index.gt.number_nodes+1) mail_search = .false.
	Enddo !Update of nodes.
	CALL LIB$PUT_OUTPUT(' ')
C
	return
	end
	SUBROUTINE CHKPRIVS(cmd_type, privl)
	IMPLICIT INTEGER(A-Z)

	INTEGER*4 icode
	CHARACTER privs*256, cmd_type*6
	LOGICAL privl
C
	INCLUDE '($LIBDEF)'
	INCLUDE '($JPIDEF)'
        PARAMETER (STR$_MATCH   = 2393113)
        PARAMETER (STR$_NOMATCH = 2392584)
C
	EXTERNAL netmail_nopriv
C
C	Set default strings and logicals.
C
	privl = .false.
C
C	Get running privelges.
C
	icode = LIB$GETJPI(JPI$_PROCPRIV,,,, privs,)
C
C	Does the process have the right privelges.
C
	icode = STR$MATCH_WILD(' ' // privs, '*OPER*')
	if (icode.eq.STR$_MATCH) then
	icode = STR$MATCH_WILD(' ' // privs, '*SYSPRV*')
	 if (icode.eq.STR$_MATCH) privl = .true.
	Endif !Priv check.
C
	If (cmd_type.ne.'SHOW') then
	If (.not.privl) CALL LIB$SIGNAL(netmail_nopriv)
	Endif
C
	return
	end

	SUBROUTINE DISPLAYREC(cmd_type, options, username, running_user,
     +               mail_data, fwd_length, per_length, modified,
     +               displayed_record, record_found, new_record, privl)
	IMPLICIT INTEGER(A-Z)
	INTEGER*4 icode, str$trim, str$position, str$match_wild
	INTEGER*4 per_len, fwd_len, name_len
	BYTE	  fwd_length, per_length
	CHARACTER username*31, running_user*31, mail_data*639
	CHARACTER*256 options(4)
	CHARACTER forward*256, personal*177, name*256, cmd_type*6
	LOGICAL privl, displayed_record, record_found, modified
	LOGICAL new_record
	PARAMETER (STR$_MATCH = 2393113)
C
C	Get record info.
C
	 If (fwd_length.ne.0) then
	 forward = mail_data(1:fwd_length)
	 icode = STR$TRIM(forward, forward, fwd_len)
	 else
	 forward = ' '
	 fwd_len = 1
	 Endif	!Forward field check.
C
	 If (per_length.ne.0) then
	 personal = mail_data(1+fwd_length:fwd_length+per_length)
	 icode = STR$TRIM(personal, personal, per_len)
	 name_len = STR$POSITION(personal(1:31), '|')
	  if (name_len.gt.0) then
	  name     = personal(1:name_len-1)
	  personal = personal(name_len+1:per_len)
	  icode = STR$UPCASE(name_match,name)
	  else
	  name = ' '
	  endif
	 else
	 name = ' '
	 personal = ' '
	 name_len = 1
	 per_len = 1
	 Endif	!Personal/Name field check.
C
C
C
	If (cmd_type.eq.'SHOW')	CALL MATCHREC(record_found, options,
     +      username, name)
	If (cmd_type.eq.'LIST') record_found = .true.
C
C	Display the record if it is a match.
C

	If((record_found).or.(new_record)) then
	displayed_record = .true.
	CALL LIB$PUT_OUTPUT(' ')
	If ((cmd_type.ne.'SHOW').and.(.not.modified))
     +       CALL LIB$PUT_OUTPUT(' Current Record -')
	 If (cmd_type.ne.'SHOW') then
	  If ((modified).or.(new_record))
     +       CALL LIB$PUT_OUTPUT(' New Record -')
	 Endif
	CALL LIB$PUT_OUTPUT(' Username: ' // username //
     +                      ' Name: ' // name(1:name_len))
C
C	If priveleged or running user matches, display forward.
C
	icode = STR$MATCH_WILD(username,running_user)
	If(icode.eq.STR$_MATCH) then
	CALL LIB$PUT_OUTPUT(' Forward: ' // forward(1:fwd_len))
	Else
	If (privl) CALL LIB$PUT_OUTPUT(' Forward: ' // forward(1:fwd_len))
	Endif !Priveleged/user match check for forward display.
C
	CALL LIB$PUT_OUTPUT(' Personal: ' // personal(1:per_len))
C
	Else !It is NOT the right record.
	record_found     = .false.
	Endif	!Display record.
C
	return
	end
	SUBROUTINE MATCHREC(record_found, options, username, name)
	IMPLICIT INTEGER(A-Z)
	INTEGER option_len, str$trim, str$match_wild, str$upcase
	CHARACTER username*31, name*256, match_name*256, options(4)*256
	LOGICAL record_found
	PARAMETER (STR$_MATCH = 2393113)
C
C	Was USERNAME selected? If so, check for USERNAME record match.
C
	icode = STR$TRIM(options(1), options(1), option_len)
	If (option_len.ne.0) then
	icode = STR$MATCH_WILD(' ' // username, options(1)(1:option_len))
	if(icode.eq.STR$_MATCH) record_found = .true.
	Endif !End USERNAME match check.
C
C	Was NAME selected? If so, check for NAME record match.
C
	icode = STR$TRIM(options(2), options(2), option_len)
	If (option_len.ne.0) then
	icode = STR$UPCASE(match_name, name)
	icode = STR$MATCH_WILD(' ' // match_name, options(2)(1:option_len))
	if(icode.eq.STR$_MATCH) record_found = .true.
	Endif !End NAME match check.
C
	return
	end
	SUBROUTINE OPENMAIL(mail_node, local_node, open_write, opened)
	IMPLICIT INTEGER(A-Z)
	INTEGER*4 str$trim, mail_len, icode, ios
	CHARACTER mail_node*31, local_node*31, mail_file*31, open_mode*4
	LOGICAL opened
	EXTERNAL netmail_mailfile, netmail_mailupd, netmail_upderr
	EXTERNAL netmail_decnet
C
C	Set strings.
C
	mail_file = ' '
	opened = .false.
C
C	Set up mail_file name (node::SYS$SYSTEM:VMSMAIL.DAT).
C
	If (mail_node.ne.local_node) then
	icode = STR$TRIM(mail_node, mail_node, mail_len)
	mail_file = mail_node(1:mail_len) // 'SYS$SYSTEM:'
	CALL LIB$SIGNAL(netmail_decnet,%val(1), mail_node(1:mail_len-2))
	 Else
	 mail_file = 'SYS$SYSTEM:'
	Endif !Mail_file name declaration.
	icode = STR$TRIM(mail_file, mail_file, mail_len)
C
C	Open the mail file. If error, set flag.
C
	If (.not.open_write) then  !open it for READONLY.
	open(unit=1, file='VMSMAIL.DAT', err=100,
     +  status='OLD', READONLY, SHARED,
     +  access='KEYED', iostat=ios,
     +  organization='INDEXED',
     +  form='UNFORMATTED',
     +  recordtype='VARIABLE',
     +  recl=177, defaultfile=mail_file(1:mail_len),
     +  key=(1:31:character))
C
	Else !Open it for write.
C
	open(unit=1, file='VMSMAIL.DAT', err=100,
     +  status='OLD', SHARED,
     +  access='KEYED', iostat=ios,
     +  organization='INDEXED',
     +  form='UNFORMATTED',
     +  recordtype='VARIABLE',
     +  recl=177, defaultfile=mail_file(1:mail_len),
     +  key=(1:31:character))
	Endif !Open file.
C
C	File opened successfully.
C
	opened = .true.
	return
C
C	File not opened! ERROR.
C
100	continue
	opened = .false.
	icode = STR$TRIM(mail_node, mail_node, mail_len)
	if (.not.open_write) then
	CALL LIB$SIGNAL(netmail_mailfile,%val(1),mail_node(1:mail_len-2))
C
	Else !Attempted update of mail file.
C
	CALL LIB$SIGNAL(netmail_mailupd,%val(1), mail_node(1:mail_len-2))
	CALL LIB$SIGNAL(netmail_upderr)
	Endif !Open error messages.
	return
C
	end
	SUBROUTINE VERIFYUPD(cmd_type, record_found, answer)
	IMPLICIT INTEGER(A-Z)
	INTEGER*4 iocde, str$upcase
	CHARACTER cmd_type*4, ans
	LOGICAL record_found, answer
	EXTERNAL netmail_abortupd
C
	answer = .false.
C
C	Ask if okay to update.
C
	CALL LIB$PUT_OUTPUT(' ')
	if (cmd_type.eq.'SET') then
	 if (record_found) CALL LIB$GET_INPUT(ans,' Ok to change? ')
	 if (.not.record_found) CALL LIB$GET_INPUT(ans,' Ok to add? ')
	Else
	 if (record_found) CALL LIB$GET_INPUT(ans,' Ok to delete? ')
	Endif !Check for delete of record.
	icode = str$upcase(ans,ans)
	if(ans.eq.'Y') answer = .true.
C
C	If it is not okay, close file and error out.
C
	If (.not.answer) then
	close(unit=1)
	CALL LIB$SIGNAL(netmail_abortupd)
	Endif !Wanted to abort.
C
	return
	end
	SUBROUTINE UPDATE(options, username, mail_data, fwd_length,
     +                    per_length, dir_length, privl, mail_node,
     +                    local_node, displayed_record)
C
	IMPLICIT INTEGER(A-Z)
	INTEGER*4 per_len, dir_len, for_len, name_len, option_len
	INTEGER*4 str$trim, colon_pos, user_len
	BYTE fwd_length, per_length, dir_length
	CHARACTER options(1)*256, mail_data*639, username*31
	CHARACTER personal*177, forward*256, directory*256, forward_node*31
	CHARACTER local_node*31, mail_node*31, name*256, forward_user*31
	EXTERNAL netmail_modfwd
C
	forward      = ' '
	forward_user = ' '
	forward_node = ' '
C
C	*****
C	Check for forward update.
C	*****
C
	icode = str$trim(options(4), options(4), option_len)
	If (option_len.ne.0) then
C
C	 Is the mail_node the same as the netmail node? Cannot set forward
C	 if it is because of infinite looping in VMSmail.
C
	 colon_pos = str$position(options(4), '::')
	 If(colon_pos.ne.0) then
	 colon_pos = colon_pos + 1
	 forward_node = options(4)(1:colon_pos)
	 forward_user = options(4)(colon_pos+1:option_len)
	 Else
	 forward_node = local_node
	 forward_user = options(4)(1:option_len)
	 Endif !Breakout of forward_node/forward_user.
C
	 If (forward_node.eq.mail_node) then
	 forward_node = ' '
	  If (forward_user.eq.username) then
	   forward_user = ' '
	   CALL LIB$SIGNAL(netmail_modfwd)
	  Endif !Match forward_user/username.
	 Endif !Match mail_node/forward_node.
C
	icode = str$trim(forward_node, forward_node, for_len)
	icode = str$trim(forward_user, forward_user, user_len)
	 If ((for_len.ne.0).and.(user_len.ne.0))
     +     forward = forward_node(1:for_len) // forward_user(1:user_len)
	 If ((for_len.eq.0).and.(user_len.ne.0))
     +     forward = forward_user(1:user_len)
	 If ((for_len.eq.0).and.(user_len.eq.0))
     +     forward = ' '
	icode = str$trim(forward, forward, for_len)
C
	Else
	 If(fwd_length.ne.0) then
	 forward = mail_data(1:fwd_length)
	 for_len = fwd_length
	 Else
	 forward = ' '
	 for_len = 0
	 Endif !Forward in mail_data check.
	Endif !Options(4) check.
C
C	*****
C	Check for personal update.
C	*****
C
	icode = str$trim(options(3), options(3), option_len)
	If (option_len.ne.0) then
	personal = options(3)(1:option_len)
	name_len=str$position(mail_data(1+fwd_length:fwd_length+31),'|')
	 If (name_len.ne.0)
     +   name = mail_data(1+fwd_length:fwd_length+name_len-1)
	per_len  = option_len
C
	Else
	If (per_length.ne.0) then
	personal = mail_data(1+fwd_length:fwd_length+per_length)
	icode = str$trim(personal, personal, per_len)
	Endif !Personal field check.
C
C	 Check to see if NAME field is present in PERSONAL field.
C
	 name_len=str$position(personal(1:31),'|')
	 If (name_len.ne.0) then
	 name = personal(1:name_len-1)
	 icode = str$trim(name, name, name_len)
	 personal = personal(name_len+2:per_len)
	 icode = str$trim(personal, personal, per_len)
	 Endif !Name update check.
	Endif !Personal update check.
C
C	*****
C	Check for name update.
C	*****
C
	icode = str$trim(options(2), options(2), option_len)
	If (option_len.ne.0) then
	name = options(2)(1:option_len)
	name_len  = option_len
C
	Else
	 icode = str$trim(name, name, name_len)
	 If (name_len.eq.0) name = ' '
	Endif !Name update check.
C
C	*****
C	Put PERSONAL and NAME fields together.
C	*****
C
	If (per_len.ne.0) then
	 If (name_len.ne.0) then
	  If (personal(1:1).eq.' ') then
	  personal = name(1:name_len) // '|' // personal(1:per_len)
	  Else
	  personal = name(1:name_len) // '| ' // personal(1:per_len)
	  Endif !NAME/PERSONAL space check.
	 Endif !NAME/PERSONAL mash.
	Else
	 If (name_len.ne.0) personal = name(1:name_len) // '| '
	 icode = str$trim(personal, personal, per_len)
	Endif !NAME mash into PERSONAL.
	icode = str$trim(personal, personal, per_len)
C
C	*****
C	Check username update.
C	*****
C
	icode = str$trim(options(1), options(1), option_len)
	If (option_len.ne.0) then
	username = options(1)(1:option_len)
	Endif !Name update check.
C
C	Build directory string, if there.
C
	If (dir_length.ne.0) then
	directory = mail_data(1+fwd_length+per_length:
     +                        fwd_length+per_length+dir_length)
	icode = str$trim(directory, directory, dir_len)
	Else
	directory = ' '
	Endif !Directory string check.
	icode = str$trim(directory, directory, dir_len)
C
C	*****
C	Build updated mail_data record
C	*****
C
	fwd_length = for_len
	per_length = per_len
	dir_length = dir_len

	mail_data = forward(1:for_len) // personal(1:per_len) //
     +              directory(1:dir_len)
C
	return
	end

	SUBROUTINE SETTRAP
	IMPLICIT INTEGER(A-Z)
	INTEGER*4 icode, ttchan, iosb(4)
	CHARACTER terminal*11 /'SYS$COMMAND'/

	EXTERNAL BRKCTRAP, BRKYTRAP
	INCLUDE '($IODEF)'
	INCLUDE '($SSDEF)'
C
C	Open terminal channel.
C
	icode = SYS$ASSIGN(terminal,ttchan,,)
	If (.not.icode) CALL LIB$STOP(%VAL(icode))
C
C	Set trap for CTRL-Y.
C
	Yfunc = IO$_SETMODE .or. IO$M_CTRLYAST
	icode = SYS$QIOW(%VAL(1),%VAL(ttchan),%VAL(Yfunc),IOSB,,,
     +                   brkYtrap,ttchan,,,,)
	If (.not.icode) CALL LIB$STOP(%VAL(icode))
	If (.not.iosb(1)) CALL LIB$STOP(%VAL(iosb(1)))
C
C	Set trap for CTRL-C.
C
	Cfunc = IO$_SETMODE .or. IO$M_CTRLCAST
	icode = SYS$QIOW(%VAL(1),%VAL(ttchan),%VAL(Cfunc),IOSB,,,
     +                   brkCtrap,ttchan,,,,)
	If (.not.icode) CALL LIB$STOP(%VAL(icode))
	If (.not.iosb(1)) CALL LIB$STOP(%VAL(iosb(1)))
C
	return
	end
	SUBROUTINE BRKCTRAP(TTCHAN)
	IMPLICIT INTEGER(A-Z)
	INTEGER*4 icode, sys$cancel, ttchan
	CHARACTER*31 original_user
	LOGICAL updating
	COMMON original_user
	COMMON updating
	EXTERNAL netmail_ctrlc, netmail_updint
	PARAMETER (LIB$M_CLI_CTRLY = '02000000'X)
C
C	Cancel all I/Os on terminal channel
C
	icode = SYS$CANCEL(%VAL(ttchan))
	if (.not.icode) CALL LIB$STOP(%VAL(icode))
C
C	Close NETMAIL file.
C
	CLOSE(unit=1)
C
C	Enable CTRL-Y.
C
	icode = LIB$ENABLE_CTRL(lib$m_cli_ctrly)
	if (.not.icode) CALL LIB$STOP(%val(icode))
C
C	Display error messages.
C
	if (updating) CALL LIB$SIGNAL(netmail_updint)
	CALL LIB$SIGNAL(netmail_ctrlc)
C
	return
	end
	SUBROUTINE BRKYTRAP(TTCHAN)
	IMPLICIT INTEGER(A-Z)
	INTEGER*4 icode, sys$dassgn, ttchan
	CHARACTER*31 original_user
	LOGICAL updating
	COMMON original_user
	COMMON updating
	EXTERNAL netmail_ctrly, netmail_updint
	PARAMETER (LIB$M_CLI_CTRLY = '02000000'X)
C
C	Cancel all I/Os on terminal channel
C
	icode = SYS$DASSGN(%VAL(ttchan))
	if (.not.icode) CALL LIB$STOP(%VAL(icode))
C
C	Disable CTRL-Y.
C
	icode = LIB$ENABLE_CTRL(lib$m_cli_ctrly)
	if (.not.icode) CALL LIB$STOP(%val(icode))
C
C	Display error messages.
C
	if (updating) CALL LIB$SIGNAL(netmail_updint)
	CALL LIB$SIGNAL(netmail_ctrly)
C
	return
	end
	SUBROUTINE SETEXIT
	INTEGER exit_status, SYS$DCLEXH
	CHARACTER*12 string
C
C	Declare exit string descriptor.
C
	STRUCTURE /descriptor/
	INTEGER size, address
	END STRUCTURE
	RECORD /descriptor/ EXIT_STRING
C
C	Declare exit handler descriptor.
C
	STRUCTURE /exit_descriptor/
	INTEGER link, addr, args /2/, status_addr, string_addr
	END STRUCTURE
	RECORD /exit_descriptor/ HANDLER
C
	EXTERNAL exit_handler
C
C	Setup decriptor.
C
	exit_string.size    = 12
	exit_string.address = %LOC (string)
C
C	Setup exit handler descriptor.
C
	handler.addr = %LOC (exit_handler)
	handler.status_addr = %LOC (exit_status)
	handler.string_addr = %LOC (exit_string)
C
C	Establish the exit handler.
C
	icode = SYS$DCLEXH(handler)
	if (.not.icode) CALL LIB$SIGNAL(%val(icode))
C
	return
	end
	SUBROUTINE EXIT_HANDLER(exit_status, exit_string)
	INTEGER exit_status
	CHARACTER original_user*31, exit_string*12
	COMMON original_user
C
C	Set username back to original.
C
	CALL SET_USER(original_user)
C
	end
