Program mailuaf C****************************************************************************** C Purpose: A utility to assist the system manager in maintaining the system C vmsmail_profile.data file. It provides the capability to add, C change, delete, and display records on this file. You must have C SYSPRV on to run this utility. C C Written: June 1988 C Author: G. Davidson C C How to invoke program: C 1) Copy mailuaf.exe to sys$system. C 2) Copy mailuafhlp.hlb to sys$help. C 3) Set up the following symbol: C $ MAILUAF :== $MAILUAF C 4) Prior issuing the "MAILUAF" command turn SETPRV on. C 5) Issue "MAILUAF" command. You can optionally specify the desired C function on the command line since mailuaf utility will support C a foreign command line. Note that the utility has been defined C with the flexibilty to maintain the system mail file referenced C by the logical VMSMAIL_PROFILE. If this logical is not defined, C then the default file used will be SYS$SYSTEM:VMSMAIL_PROFILE.DATA. C C Mailuaf Utility's Commands: C Command Qualifiers Description of Command C ------- ----------- ---------------------------------------------------- C ADD Create new entry in VMSMAIL_PROFILE.DATA file. C /AUTO_PURGE C /CC_PROMPT C /COPY_SELF C /EDITOR C /FORM C /FORWARD C /MAIL_DIRECTORY C /PERSONAL_NAME C /QUEUE C C EXIT Exit out of mailuaf utility. C C HELP Provide help on the mailuaf utility commands. C C LIST Provides a diplay about each record on C VMSMAIL_PROFILE.DATA file. C /BRIEF C /FULL C MODIFY Modify any field for a particular user on the C VMSMAIL_PROFILE.DATA file. C /AUTO_PURGE C /CC_PROMPT C /COPY_SELF C /EDITOR C /FORM C /FORWARD C /MAIL_DIRECTORY C /PERSONAL_NAME C /QUEUE C C REMOVE Remove a user's record from the VMSMAIL_PROFILE.DATA C file. C C SHOW Display mail information about a selected user on C the VMSMAIL_PROFILE.DATA file. C C History: C C 11-Aug-1988 Gld Added validation logic to add and modify subroutines for C fields - form,fowarding name,personal name, and queue. C****************************************************************************** Implicit integer*4 (a-z) External mailuaf_table External lib$get_input External cli$_normal External jpi$_curpriv Character*512 Command_line Integer*2 Command_len Character*1 Bell Parameter (Bell= Char(7)) Integer*4 Status Integer*4 lib$get_input,lib$get_foreign Integer*4 cli$dcl_parse,cli$dispatch Integer*4 sys$trnlnm Integer*4 sys$getjpi Logical*2 Foreign_command External lnm$_string Character*255 logical_name Integer*4 logical_name_length Integer*4 current_priv(2) Integer*4 mask,curprv_mask Integer*4 curprv_length Character*64 curprv Equivalence (curprv,current_priv) Logical*4 sysprv_on Structure /itmlst/ Union Map Integer*2 buflen Integer*2 itmcod Integer*4 bufadr Integer*4 retadr End map Map Integer*4 end_list End map End union End structure Structure /quad_priv_mask/ integer*4 longword_1 /0/ integer*4 longword_2 /0/ end structure Record /quad_priv_mask/current_priv_mask Record /itmlst/ trnlnm_list(2) Record /itmlst/ getjpi_list(2) Include '($ssdef)' Include '($rmsdef)' Include '($prvdef)' Include '($foriosdef)' Common status,foreign_command C************************** C***** Mainline code ****** C************************** C C C Check to see if person invoking this program has the SYSPRV privilege. C If no, then force error message %SYSTEM-F-NOPRIV, no privilege for attempted C operation and then abort program. C Getjpi_list(1).buflen = 8 Getjpi_list(1).itmcod = %loc(jpi$_curpriv) Getjpi_list(1).bufadr = %loc(current_priv_mask) Getjpi_list(1).retadr = %loc(curprv_length) Getjpi_list(2).end_list = 0 C C Get current process's current privileges. C Status = sys$getjpi (,,,getjpi_list,,,) If (status .ne. ss$_normal) then C (Serious error occurred, display error message and abort program) call lib$signal(%val(status)) call sys$exit(%val(status)) endif C C Check if SYSPRV bit set in privilege mask returned by SYS$GETJPI. C Note that prv$v_sysprv refers to the number of the bit in the privilege C mask which refers to the sysprv privilege. C Sysprv_on = + bjtest(current_priv_mask.longword_1,prv$v_sysprv) If (.not. sysprv_on) call sys$exit(%val(ss$_nopriv)) C C Determine the name of the system mail file. If the logical 'VMSMAIL_PROFILE' C has been defined, then use that name. Otherwise use the name C SYS$SYSTEM:VMSMAIL_PROFILE.DATA. C Trnlnm_list(1).buflen = 255 Trnlnm_list(1).itmcod = %loc(lnm$_string) Trnlnm_list(1).bufadr = %loc(logical_name) Trnlnm_list(1).retadr = %loc(logical_name_length) Trnlnm_list(2).end_list = 0 Status = sys$trnlnm (,'LNM$FILE_DEV', + 'VMSMAIL_PROFILE',,trnlnm_list) If (status .eq. ss$_nolognam) then C (Use this name since logical not defined) logical_name ='sys$system:vmsmail_profile.data' logical_name_length=31 else If (status .ne. ss$_normal) then C (Serious error occurred, display error message and abort program) call lib$signal(%val(status)) call sys$exit(%val(status)) endif endif C C Open the mail file. C Open(1,name=logical_name(1:logical_name_length), + access='keyed',organization='indexed',status='old', + shared,iostat=status,form='formatted') If (status .ne. 0) then Print *,' ' Print *,Bell,Bell, + '%MAILUAF-F-NOOPEN, cannot open mail file' Call abort Endif C C Examine the command line entered. C Status = Lib$get_foreign(command_line,,command_len,) If (status .eq. ss$_normal)then If (command_len .gt. 0)then C C*** If you reach this point, qualifiers were entered by C*** the user on the command line. C Foreign_command = .true. Status = cli$dcl_parse(command_line(1:command_len), + mailuaf_table, + lib$get_input, + lib$get_input, + 'MAILUAF>') If (status .eq. %loc(cli$_normal)) call cli$dispatch() Else C C*** If you reach this point, the user has entered the MAILUAF C*** command without specifying any qualifiers. Therefore, prompt C*** them for the desired functions. C Foreign_command = .false. Do while (status .ne. rms$_eof) Status = cli$dcl_parse(%val(0), + mailuaf_table, + lib$get_input, + lib$get_input, + 'MAILUAF>') If (status .eq. %loc(cli$_normal)) + call cli$dispatch() End do Endif Else C (Serious error occurred, display error message and abort program) call lib$signal(%val(status)) call sys$exit(%val(status)) Endif C C*** Now close the mail file and terminate the program. C Close(1) 9999 If (status .eq. ss$_normal .or. status .eq. rms$_eof) then Call exit Else Call sys$exit(%val(status)) Endif End Subroutine add_user C C******************************************* C**** Logic invoked by the ADD command **** C******************************************* C Logical*2 file_exists Character*255 editor_executable Character*1 BELL Parameter (BELL= Char(7)) Integer*4 sys$getuai External uai$_defdev External uai$_defdir Character*32 defdev Character*64 defdir Integer*4 defdev_length Integer*4 defdir_length Integer*4 lib$create_dir Integer*4 str$trim Integer*4 str$position Character*12 Usrnam Integer*4 cli$get_value Integer*4 cli$present External cli$_present External cli$_absent External cli$_negated Character*31 User_text Integer*2 user_length Integer*4 status Integer*4 size Character*255 dev_dir_spec Integer*2 dev_dir_spec_length Logical*2 foreign_command Integer*2 spaces_position Integer*4 ascii_value Character*2048 mail_record Character*4 field_type_char Character*4 field_length_char Integer*2 field_type Integer*2 field_length Integer*2 field_begin Integer*2 field_end Integer*2 field_end2 Character*2048 field_text_char Integer*2 field_text Integer*2 position Structure /itmlst/ Union Map Integer*2 buflen Integer*2 itmcod Integer*4 bufadr Integer*4 retadr End map Map Integer*4 end_list End map End union End structure Record /itmlst/ getsysi_list(3) Integer*2 newmail_count Integer*2 flags Integer*2 mask Integer*2 flag_setting Character*7 copy_input Integer*2 copy_input_length Logical*2 copy_send Logical*2 copy_reply Logical*2 auto_purge Logical*2 copy_forward Logical*2 cc_prompt Character*80 flag_display Character*512 subdir_name Integer*2 subdir_name_length Character*512 forwarding_name Integer*2 forwarding_name_length Character*512 personal_name Integer*2 personal_name_length Character*512 mailplus_cell Integer*2 mailplus_cell_length Character*512 transport Integer*2 transport_length Character*512 editor Integer*2 editor_length Character*512 queue Integer*2 queue_length Character*512 user_defined1 Integer*2 user_defined1_length Character*512 user_defined2 Integer*2 user_defined2_length Character*512 user_defined3 Integer*2 user_defined3_length Character*512 print_form Integer*2 print_form_length Character*512 spare1 Integer*2 spare1_length Character*512 spare2 Integer*2 spare2_length Include '($ssdef)' Include '($strdef)' Include '($libdef)' Include '($rmsdef)' Include '($foriosdef)' Equivalence(field_type_char,field_type) Equivalence(field_length_char,field_length) Equivalence(field_text_char(1:2),field_text) Common status,foreign_command C C Field initialization logic C copy_send = .false. copy_reply = .false. auto_purge = .true. copy_forward = .false. cc_prompt = .false. subdir_name_length = 0 forwarding_name_length = 0 personal_name_length = 0 editor_name_length = 0 queue_length = 0 print_form_length = 0 C C Get username value from command line. C Call cli$get_value('USER',user_text,user_length) C C User name was entered. Now see if any record in mail file has this username C key. C Read(1,'(q,a)',key=user_text(1:user_length),keyid=0, + iostat=status) size,mail_record(1:size) If (status .eq. for$ios_attaccnon) goto 10 C C Now check to see if an exact key match was obtained. If found display C error message. C If (mail_record(1:31) .eq. user_text) then C (Logic when record already exist on file) Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-EXIST, user ',USER_TEXT(1:USER_LENGTH), + ' already exist in mail file' Print *,'%MAILUAF-E-NOADD, add not performed' If (foreign_command ) then C (Force error condition to %SYSTEM-F-DUPLNAM, duplicate name C and then abort program) status = ss$_duplnam call sys$exit(%val(status)) Else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return Endif Endif C C Determine the default device and default directory for the specified C user by issuing the system service call SYS$GETUAI. C 10 Usrnam = user_text(1:user_length) Getsysi_list(1).buflen = 32 Getsysi_list(1).itmcod = %loc(uai$_defdev) Getsysi_list(1).bufadr = %loc(defdev) Getsysi_list(1).retadr = %loc(defdev_length) Getsysi_list(2).buflen = 64 Getsysi_list(2).itmcod = %loc(uai$_defdir) Getsysi_list(2).bufadr = %loc(defdir) Getsysi_list(2).retadr = %loc(defdir_length) Getsysi_list(3).end_list = 0 Status = sys$getuai(,,usrnam,getsysi_list,,,) C C If no user was found on sysuaf.dat, print error message and terminate C program. C If (status .eq. rms$_rnf) then Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-NOFIND, user ',USER_TEXT(1:USER_LENGTH), + ' not found on sysuaf.dat file' Print *,'%MAILUAF-E-NOADD, add not performed' If (foreign_command ) then call abort else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return endif endif If (status .ne. ss$_normal) then call lib$signal(%val(status)) call sys$exit(%val(status)) endif C C Now get all the remaining fields contained on the command line. C Status = cli$present('AUTO_PURGE') C C AUTO_PURGE qualifier C If (status .eq. %loc(cli$_negated)) then auto_purge = .false. else auto_purge = .true. endif C C CC_PROMPT qualifier C Status = cli$present('CC_PROMPT') If (status .eq. %loc(cli$_present)) then cc_prompt = .true. else cc_prompt = .false. endif C C COPY_SELF qualifier C Status = cli$present('COPY_SELF') If (status .eq. %loc(cli$_present)) then status = cli$get_value('copy_self', + copy_input,copy_input_length) Do while (status .NE. %loc(cli$_absent)) if (copy_input(1:copy_input_length) + .eq. 'SEND') copy_send = .true. if (copy_input(1:copy_input_length) + .eq. 'NOSEND') copy_send = .false. if (copy_input(1:copy_input_length) + .eq. 'REPLY') copy_reply = .true. if (copy_input(1:copy_input_length) + .eq. 'NOREPLY') copy_reply = .false. if (copy_input(1:copy_input_length) + .eq. 'FORWARD') copy_forward = .true. if (copy_input(1:copy_input_length) + .eq. 'NOFORWARD') copy_forward = .false. status = cli$get_value('copy_self', + copy_input,copy_input_length) end do else copy_send = .false. copy_reply = .false. copy_forward = .false. endif C C EDITOR qualifier C Status = cli$present('EDITOR') If (status .eq. %loc(cli$_present)) then call cli$get_value('editor',editor,editor_length) else editor = ' ' editor_length = 0 endif C C FORM qualifier C Status = cli$present('FORM') If (status .eq. %loc(cli$_present)) then call cli$get_value('form',print_form,print_form_length) else print_form = ' ' print_form_length = 0 endif C C FORWARD qualifier C Status = cli$present('FORWARD') If (status .eq. %loc(cli$_present)) then call cli$get_value('forward',forwarding_name, + forwarding_name_length) else forwarding_name = ' ' forwarding_name_length = 0 endif C C MAIL_DIRECTORY qualifier C Status = cli$present('MAIL_DIRECTORY') If (status .eq. %loc(cli$_present)) then call cli$get_value('mail_directory',subdir_name, + subdir_name_length) else subdir_name = ' ' subdir_name_length = 0 endif C C PERSONAL_NAME qualifier C Status = cli$present('PERSONAL_NAME') If (status .eq. %loc(cli$_present)) then call cli$get_value('personal_name',personal_name, + personal_name_length) else personal_name = ' ' personal_name_length = 0 endif C C QUEUE qualifier C Status = cli$present('QUEUE') If (status .eq. %loc(cli$_present)) then call cli$get_value('queue',queue,queue_length) else queue = ' ' queue_length = 0 endif C C Now validate format of form if specified. Field must not exceed 255 bytes. C If (print_form_length .gt. 255) then Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-BADLEN, form name is too long' Print *,'%MAILUAF-E-NOADD, add not performed' If (foreign_command ) then C (Force error condition to %SYSTEM-F-IVBUFLEN C and then abort program) status = ss$_ivbuflen call sys$exit(%val(status)) else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return endif endif C C Now validate format of forwarding name if specified. Field must not exceed C 255 bytes. C If (forwarding_name_length .gt. 255) then Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-BADLEN, forwarding name is too long' Print *,'%MAILUAF-E-NOADD, add not performed' If (foreign_command ) then C (Force error condition to %SYSTEM-F-IVBUFLEN C and then abort program) status = ss$_ivbuflen call sys$exit(%val(status)) else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return endif endif C C Now validate format of mail subdirectory if specified. Field must begin C with '[.' and end with ']'. C If (subdir_name_length .gt. 0) then If ((subdir_name(1:2) .ne. '[.') .or. + (subdir_name(subdir_name_length:subdir_name_length) + .ne. ']')) then C (Logic when invalid format specified) Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-NOTSUBDIR, parameter ', + subdir_name(1:subdir_name_length), + ' does not specify a subdirectory' Print *,'%MAILUAF-E-NOADD, add not performed' If (foreign_command ) then C (Force error condition to %SYSTEM-F-BADIRECTORY, bad directory C and then abort program) status = ss$_badirectory call sys$exit(%val(status)) else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return endif endif endif C C Now validate format of personal name if specified. C 1) Field must not exceed 255 bytes. C 2) First character must be alphabetic C 3) String cannot contain consecutive spaces C If (personal_name_length .gt. 255) then C Error logic if invalid length. Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-BADLEN, personal name is too long' Print *,'%MAILUAF-E-NOADD, add not performed' If (foreign_command ) then C (Force error condition to %SYSTEM-F-IVBUFLEN C and then abort program) status = ss$_ivbuflen call sys$exit(%val(status)) else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return endif endif If (personal_name_length .gt. 0) then ascii_value = ichar(personal_name(1:1)) If ((ascii_value .lt. 65) .or. + (ascii_value .gt. 90 .and. ascii_value .lt. 97) + .or. (ascii_value .gt. 122)) then C Error logic if first character isn't a valid uppercase or lowercase C letter. Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-BADFORMAT, 1st character of personal ', + 'name not alphabetic' Print *,'%MAILUAF-E-NOADD, add not performed' If (foreign_command ) then C (Force error condition to %SYSTEM-F-IVCHAR C and then abort program) status = ss$_ivchar call sys$exit(%val(status)) else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return endif endif endif If (personal_name_length .gt. 0) then Spaces_position = + str$position(personal_name(1:personal_name_length),' ') If (spaces_position .gt. zero) then C Error logic if consecutive spaces found in string. Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-BADFORMAT, personal name cannot have ', + 'multiple spaces' Print *,'%MAILUAF-E-NOADD, add not performed' If (foreign_command ) then C (Force error condition to %SYSTEM-F-IVCHAR C and then abort program) status = ss$_ivchar call sys$exit(%val(status)) else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return endif endif endif C C Now validate format of queue if specified. Field must not exceed 255 bytes. C If (queue_length .gt. 255) then Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-BADLEN, queue name is too long' Print *,'%MAILUAF-E-NOADD, add not performed' If (foreign_command ) then C (Force error condition to %SYSTEM-F-IVBUFLEN C and then abort program) status = ss$_ivbuflen call sys$exit(%val(status)) else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return endif endif C C Now build new record to be added to mail file. The layout of each new C record is the following. The first 31 bytes contain the username. C Following the username field which is always 31 bytes are appended C a series of variable length fields. The variable data format is a C sequence of data fields in the following format: C Field type WORD C Field length WORD C Data STRING/WORD depending on field type C There are fifteen different field types. They are the following: C Value of Definition Data type based Optional field vs C Field Type of Field Type on Field Type required C ---------- --------------- --------------- ----------------- C 1 New mail count WORD required C 2 Flag field WORD required C 3 Mail subdirectory CHARACTER optional C 4 Forwarding name CHARACTER optional C 5 Personal name CHARACTER optional C 6 Mailplus cell CHARACTER optional C 7 Transport CHARACTER optional C 8 Mail editor CHARACTER optional C 9 Default queue CHARACTER optional C 10 User defined 1 CHARACTER optional C 11 User defined 2 CHARACTER optional C 12 User defined 3 CHARACTER optional C 13 Default form CHARACTER optional C 14 Spare 1 CHARACTER optional C 15 Spare 2 CHARACTER optional C C- Username mail_record(1:31) = user_text(1:user_length) C- New mail count - initialize to zero. field_type = 1 mail_record(32:33) = field_type_char field_length = 2 mail_record(34:35) = field_length_char field_text = 0 mail_record(36:37) = field_text_char C- Flag field C C Bit setting Meaning C ----------- ------- C 0000 0001 Copy-self on send C 0000 0010 Copy-self on reply C 0000 0100 Do not auto-purge C 0000 1000 Copy-self on forward C 0001 0000 Prompt for carbon-copy C field_type = 2 mail_record(38:39) = field_type_char field_length = 2 mail_record(40:41) = field_length_char flag_setting = 0 if (copy_send) flag_setting = iior(flag_setting,1) if (copy_reply) flag_setting = iior(flag_setting,2) if (.not. auto_purge) flag_setting = iior(flag_setting,4) if (copy_forward) flag_setting = iior(flag_setting,8) if (cc_prompt) flag_setting = iior(flag_setting,16) field_text = flag_setting mail_record(42:43) = field_text_char field_end = 43 C-Mail directory if (subdir_name_length .gt. 0) then field_begin = field_end + 1 field_end = field_begin + 1 field_type = 3 mail_record(field_begin:field_end) = field_type_char field_begin = field_end + 1 field_end = field_begin + 1 field_length = subdir_name_length mail_record(field_begin:field_end) = field_length_char field_begin = field_end + 1 field_end = field_end + subdir_name_length mail_record(field_begin:field_end) = subdir_name endif C-Forwarding name if (forwarding_name_length .gt. 0) then field_begin = field_end + 1 field_end = field_begin + 1 field_type = 4 mail_record(field_begin:field_end) = field_type_char field_begin = field_end + 1 field_end = field_begin + 1 field_length = forwarding_name_length mail_record(field_begin:field_end) = field_length_char field_begin = field_end + 1 field_end = field_end + forwarding_name_length mail_record(field_begin:field_end) = forwarding_name endif C-Personal name if (personal_name_length .gt. 0) then field_begin = field_end + 1 field_end = field_begin + 1 field_type = 5 mail_record(field_begin:field_end) = field_type_char field_begin = field_end + 1 field_end = field_begin + 1 field_length = personal_name_length mail_record(field_begin:field_end) = field_length_char field_begin = field_end + 1 field_end = field_end + personal_name_length mail_record(field_begin:field_end) = personal_name endif C-Editor if (editor_length .gt. 0) then field_begin = field_end + 1 field_end = field_begin + 1 field_type = 8 mail_record(field_begin:field_end) = field_type_char field_begin = field_end + 1 field_end = field_begin + 1 field_length = editor_length mail_record(field_begin:field_end) = field_length_char field_begin = field_end + 1 field_end = field_end + editor_length mail_record(field_begin:field_end) = editor endif C-Queue if (queue_length .gt. 0) then field_begin = field_end + 1 field_end = field_begin + 1 field_type = 9 mail_record(field_begin:field_end) = field_type_char field_begin = field_end + 1 field_end = field_begin + 1 field_length = queue_length mail_record(field_begin:field_end) = field_length_char field_begin = field_end + 1 field_end = field_end + queue_length mail_record(field_begin:field_end) = queue endif C-Print form if (print_form_length .gt. 0) then field_begin = field_end + 1 field_end = field_begin + 1 field_type = 13 mail_record(field_begin:field_end) = field_type_char field_begin = field_end + 1 field_end = field_begin + 1 field_length = print_form_length mail_record(field_begin:field_end) = field_length_char field_begin = field_end + 1 field_end = field_end + print_form_length mail_record(field_begin:field_end) = print_form endif C (Note the length of the new mail record just build) size = field_end C C If an editor type has been specified on the command line, make sure that C it is a valid editor type. All valid editor types are contained in the C directory sys$library. There should be a file in this directory called C '(editor name)shr.exe'. C If (editor_length .gt. 0) then editor_executable = 'sys$common:[syslib]' field_end = editor_length + 19 editor_executable(20:field_end) = editor field_begin = field_end + 1 field_end = field_end + 7 editor_executable(field_begin:field_end) = 'shr.exe' Inquire(file=editor_executable,exist=file_exists, + iostat=status) If (.not. file_exists) then C (Logic when not a valid editor type) Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-ERACTED, error activating editor ', + editor(1:editor_length) Print *,'%MAILUAF-E-OPENIN,error opening ', + 'sys$common:[syslib]',editor(1:editor_length), + 'shr.exe; as input' Print *,'%MAILUAF-E-NOADD, add not performed' If (foreign_command ) then C (Force error condition to %RMS-E-FNF,file not found C and then abort program) status = rms$_fnf call sys$exit(%val(status)) else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return endif endif endif If (subdir_name_length .eq. 0) goto 30 C C If mail directory was specified, create the mail directory. C Step 1: get required info from sysuaf.dat to construct directory spec. C Step 2: issue system service to create directory. C C First build a field containing the name of the C device:[directory.subdirectory] file spec. C If (defdev_length .gt. 0) + Call str$trim(defdev,defdev,defdev_length) If (defdir_length .gt. 0) + Call str$trim(defdir,defdir,defdir_length) Dev_dir_spec = defdev(2:defdev_length) Field_begin = defdev_length Field_end2 = defdir_length - 1 Field_end = field_begin + defdir_length - 3 Dev_dir_spec(field_begin:field_end) = defdir(2:field_end2) Field_begin = field_end + 1 Dev_dir_spec(field_begin:255) = + subdir_name(2:subdir_name_length) Call str$trim(dev_dir_spec,dev_dir_spec,dev_dir_spec_length) C C Create the mail subdirectory. Note, if the subdirectory already exists, the C system subroutine lib$create_dir will return the ss$_normal status code. C Status = lib$create_dir(dev_dir_spec(1:dev_dir_spec_length), + 0,,,,) If (status .eq. ss$_created) then C (Inform user that subdirectory was created.) Print *,'%MAILUAF-I-CREATED, ', + dev_dir_spec(1:dev_dir_spec_length), + ' created' else If (status .eq. ss$_normal) then C (Inform user that subdirectory already exists.) Print *,'%MAILUAF-I-EXISTS, ', + dev_dir_spec(1:dev_dir_spec_length), + ' already exists' else Call abort endif endif C C Now add the record to the mail file C 30 Write(1,'(a)',iostat=status) mail_record(1:size) If (status .ne. 0) call abort Print *,'%MAILUAF-I-ADD, user ',user_text(1:user_length), + ' was added to mail file' Status = ss$_normal end Subroutine done C C******************************************* C**** Logic invoked by the EXIT command **** C******************************************* C Close(1) ! Close the mail file Call exit ! All done, so end the program End Subroutine help_user C C******************************************* C**** Logic invoked by the HELP command **** C******************************************* C External lib$put_output,lib$get_input Integer*4 lib$put_output,lib$get_input Integer*4 cli$get_value,lbr$output_help Character*512 command_text Integer*2 command_length Integer*4 command_len Integer*4 status Logical*2 Foreign_command Include '($ssdef)' Common status,foreign_command Call cli$get_value('TOPIC',command_text,command_length) Command_len = command_length Status = lbr$output_help(lib$put_output, + command_len, + command_text, + 'sys$help:mailuafhlp.hlb',, + lib$get_input) If (status .ne. ss$_normal)then C*** (Serious error has occurred, so abort program) call lib$signal(%val(status)) call sys$exit(%val(status)) endif End Subroutine modify_user C C******************************************* C**** Logic invoked by the MODIFY command **** C******************************************* C Logical*2 file_exists Character*255 editor_executable Character*1 BELL Parameter (BELL= Char(7)) Integer*4 sys$getuai External uai$_defdev External uai$_defdir Character*32 defdev Character*64 defdir Integer*4 defdev_length Integer*4 defdir_length Integer*4 lib$create_dir Integer*4 lib$rename_file Integer*4 str$trim Integer*4 str$position Character*12 Usrnam Integer*4 cli$get_value Integer*4 cli$present External cli$_present External cli$_absent External cli$_negated Character*31 User_text Integer*2 user_length Integer*4 status Integer*4 size Character*255 dev_dir_spec Integer*2 dev_dir_spec_length Character*255 old_mail_files_spec Integer*2 old_spec_length Character*255 new_mail_files_spec Integer*2 new_spec_length Logical*2 foreign_command Integer*2 spaces_position Integer*4 ascii_value Character*2048 mail_record Character*2048 new_mail_record Character*4 field_type_char Character*4 field_length_char Integer*2 field_type Integer*2 field_length Integer*2 field_begin Integer*2 field_begin2 Integer*2 field_end Integer*2 field_end2 Character*2048 field_text_char Integer*2 field_text Integer*2 position Structure /itmlst/ Union Map Integer*2 buflen Integer*2 itmcod Integer*4 bufadr Integer*4 retadr End map Map Integer*4 end_list End map End union End structure Record /itmlst/ getsysi_list(3) Integer*2 newmail_count Integer*2 flags Integer*2 mask Integer*2 flag_setting Character*7 copy_input Integer*2 copy_input_length Logical*2 copy_send Logical*2 copy_reply Logical*2 auto_purge Logical*2 copy_forward Logical*2 cc_prompt Character*80 flag_display Character*512 subdir_name Integer*2 subdir_name_length Character*512 old_subdir_name Integer*2 old_subdir_name_length Character*512 forwarding_name Integer*2 forwarding_name_length Character*512 personal_name Integer*2 personal_name_length Character*512 mailplus_cell Integer*2 mailplus_cell_length Character*512 transport Integer*2 transport_length Character*512 editor Integer*2 editor_length Character*512 queue Integer*2 queue_length Character*512 user_defined1 Integer*2 user_defined1_length Character*512 user_defined2 Integer*2 user_defined2_length Character*512 user_defined3 Integer*2 user_defined3_length Character*512 print_form Integer*2 print_form_length Character*512 spare1 Integer*2 spare1_length Character*512 spare2 Integer*2 spare2_length Include '($ssdef)' Include '($strdef)' Include '($libdef)' Include '($rmsdef)' Include '($foriosdef)' Equivalence(field_type_char,field_type) Equivalence(field_length_char,field_length) Equivalence(field_text_char(1:2),field_text) Common status,foreign_command C C Field initialization logic C copy_send = .false. copy_reply = .false. auto_purge = .true. copy_forward = .false. cc_prompt = .false. subdir_name_length = 0 old_subdir_name_length = 0 forwarding_name_length = 0 personal_name_length = 0 mailplus_cell_length = 0 transport_length = 0 editor_name_length = 0 user_defined1_length = 0 user_defined2_length = 0 user_defined3_length = 0 queue_length = 0 print_form_length = 0 spare1_length = 0 spare2_length = 0 new_mail_record = ' ' subdir_name = ' ' old_subdir_name = ' ' position = 32 C C Get username value from command line. C Call cli$get_value('USER',user_text,user_length) C C User name was entered. Now read the record in mail file with this username C key. C Read(1,'(q,a)',key=user_text(1:user_length),keyid=0, + iostat=status) size,mail_record(1:size) If (status .eq. for$ios_attaccnon) then C (Logic when record not found in file) Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-NOFIND, user ',USER_TEXT(1:USER_LENGTH), + ' not found in mail file' Print *,'%MAILUAF-E-NOMODIFY, modify not performed' If (foreign_command ) then call abort ! abort pgm and display error message else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return endif else If (status .ne. 0) call abort !error has occurred,so abort program endif C C Now check to see if an exact key match was obtained. If no, then display C message and terminate program. C If (mail_record(1:31) .ne. user_text) then Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-NOFIND, user ',USER_TEXT(1:USER_LENGTH), + ' not found in mail file' Print *,'%MAILUAF-E-NOMODIFY, modify not performed' If (foreign_command ) then C (Force error condition to %RMS-E-RFN, record not found, and C abort program) status = rms$_rnf call sys$exit(%val(status)) else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return endif endif C C Determine the default device, default directory for the specified user C by issuing the system service call SYS$GETUAI. C Usrnam = user_text(1:user_length) Getsysi_list(1).buflen = 32 Getsysi_list(1).itmcod = %loc(uai$_defdev) Getsysi_list(1).bufadr = %loc(defdev) Getsysi_list(1).retadr = %loc(defdev_length) Getsysi_list(2).buflen = 64 Getsysi_list(2).itmcod = %loc(uai$_defdir) Getsysi_list(2).bufadr = %loc(defdir) Getsysi_list(2).retadr = %loc(defdir_length) Getsysi_list(3).end_list = 0 Status = sys$getuai(,,usrnam,getsysi_list,,,) If (status .eq. rms$_rnf) then defdev = ' ' defdev_length = 0 defdir = ' ' defdir_length = 0 else If (status .ne. ss$_normal) call abort endif If (defdev_length .gt. 0) + Call str$trim(defdev,defdev,defdev_length) If (defdir_length .gt. 0) + Call str$trim(defdir,defdir,defdir_length) C C *** If you reach this point, record found on mail file. Now analyze the C *** record's contents. Following the username field (length 31) are appended C *** a series of variable length fields. The variable data format is a C *** sequence of data fields in the following format: C Field type WORD C Field length WORD C Data STRING/WORD depending on field type C Do while (position .le. size) C (Extract field type from field_end = position + 1 field_type_char = mail_record(position:field_end) field_begin = position + 2 field_end = position + 3 field_length_char = mail_record(field_begin:field_end) field_begin = position + 4 field_end = field_begin + field_length - 1 field_text_char = mail_record(field_begin:field_end) position = field_end + 1 C If (field_type .eq. 1) then C (If true, then data field contains value of new mail count) newmail_count = field_text goto 20 endif If (field_type .eq. 2) then C (If true, then data field is the flag field) flags = field_text C C Now analyze the bit settings in flag field C C Bit setting Meaning C ----------- ------- C 0000 0001 Copy-self on send C 0000 0010 Copy-self on reply C 0000 0100 Do not auto-purge C 0000 1000 Copy-self on forward C 0001 0000 Prompt for carbon-copy C mask = 1 flag_setting = iiand(field_text,mask) if (flag_setting .eq. 1) copy_send = .true. mask = 2 flag_setting = iiand(field_text,mask) if (flag_setting .eq. 2) copy_reply = .true. mask = 4 flag_setting = iiand(field_text,mask) if (flag_setting .eq. 4) auto_purge = .false. mask = 8 flag_setting = iiand(field_text,mask) if (flag_setting .eq. 8) copy_forward = .true. mask = 16 flag_setting = iiand(field_text,mask) if (flag_setting .eq. 16) cc_prompt = .true. goto 20 endif If (field_type .eq. 3) then C (If true, then data field contains value of mail subdirectory name) subdir_name = field_text_char subdir_name_length = field_length old_subdir_name = subdir_name old_subdir_name_length = subdir_name_length goto 20 endif If (field_type .eq. 4) then C (If true, then data field contains value of forwarding name) forwarding_name = field_text_char forwarding_name_length = field_length goto 20 endif If (field_type .eq. 5) then C (If true, then data field contains value of personal name) personal_name = field_text_char personal_name_length = field_length goto 20 endif If (field_type .eq. 6) then C (If true, then data field contains value of mailplus cell) mailplus_cell = field_text_char mailplus_cell_length = field_length goto 20 endif If (field_type .eq. 7) then C (If true, then data field contains value of transport) transport = field_text_char transport_length = field_length goto 20 endif If (field_type .eq. 8) then C (If true, then data field contains value of mail editor) editor = field_text_char editor_length = field_length goto 20 endif If (field_type .eq. 9) then C (If true, then data field contains value of default queue name) queue = field_text_char queue_length = field_length goto 20 endif If (field_type .eq. 10) then C (If true, then data field contains value of user defined field 1) user_defined1 = field_text_char user_defined1_length = field_length goto 20 endif If (field_type .eq. 11) then C (If true, then data field contains value of user defined field 2) user_defined2 = field_text_char user_defined2_length = field_length goto 20 endif If (field_type .eq. 12) then C (If true, then data field contains value of user defined field 3) user_defined3 = field_text_char user_defined3_length = field_length goto 20 endif If (field_type .eq. 13) then C (If true, then data field contains value of default print form) print_form = field_text_char print_form_length = field_length goto 20 endif If (field_type .eq. 14) then C (If true, then data field contains value of spare field 1) spare1 = field_text_char spare1_length = field_length goto 20 endif If (field_type .eq. 15) then C (If true, then data field contains value of spare field 2) spare2 = field_text_char spare2_length = field_length goto 20 endif 20 end do C C Now get all the remaining fields contained on the command line. C Status = cli$present('AUTO_PURGE') C C AUTO_PURGE qualifier C If (status .eq. %loc(cli$_negated)) then auto_purge = .false. else If (status .eq. %loc(cli$_present)) auto_purge = .true. endif C C CC_PROMPT qualifier C Status = cli$present('CC_PROMPT') If (status .eq. %loc(cli$_negated)) then cc_prompt = .false. else If (status .eq. %loc(cli$_present)) cc_prompt = .true. endif C C COPY_SELF qualifier C Status = cli$present('COPY_SELF') If (status .eq. %loc(cli$_present)) then status = cli$get_value('copy_self', + copy_input,copy_input_length) Do while (status .NE. %loc(cli$_absent)) if (copy_input(1:copy_input_length) + .eq. 'SEND') copy_send = .true. if (copy_input(1:copy_input_length) + .eq. 'NOSEND') copy_send = .false. if (copy_input(1:copy_input_length) + .eq. 'REPLY') copy_reply = .true. if (copy_input(1:copy_input_length) + .eq. 'NOREPLY') copy_reply = .false. if (copy_input(1:copy_input_length) + .eq. 'FORWARD') copy_forward = .true. if (copy_input(1:copy_input_length) + .eq. 'NOFORWARD') copy_forward = .false. status = cli$get_value('copy_self', + copy_input,copy_input_length) end do endif C C EDITOR qualifier C Status = cli$present('EDITOR') If (status .eq. %loc(cli$_present)) then call cli$get_value('editor',editor,editor_length) else If (status .eq. %loc(cli$_negated)) then editor = ' ' editor_length = 0 endif endif C C FORM qualifier C Status = cli$present('FORM') If (status .eq. %loc(cli$_present)) then call cli$get_value('form',print_form,print_form_length) else If (status .eq. %loc(cli$_negated)) then print_form = ' ' print_form_length = 0 endif endif C C FORWARD qualifier C Status = cli$present('FORWARD') If (status .eq. %loc(cli$_present)) then call cli$get_value('forward',forwarding_name, + forwarding_name_length) else If (status .eq. %loc(cli$_negated)) then forwarding_name = ' ' forwarding_name_length = 0 endif endif C C MAIL_DIRECTORY qualifier C Status = cli$present('MAIL_DIRECTORY') If (status .eq. %loc(cli$_present)) then call cli$get_value('mail_directory',subdir_name, + subdir_name_length) else If (status .eq. %loc(cli$_negated)) then subdir_name = ' ' subdir_name_length = 0 endif endif C C PERSONAL_NAME qualifier C Status = cli$present('PERSONAL_NAME') If (status .eq. %loc(cli$_present)) then call cli$get_value('personal_name',personal_name, + personal_name_length) else If (status .eq. %loc(cli$_negated)) then personal_name = ' ' personal_name_length = 0 endif endif C C QUEUE qualifier C Status = cli$present('QUEUE') If (status .eq. %loc(cli$_present)) then call cli$get_value('queue',queue,queue_length) else If (status .eq. %loc(cli$_negated)) then queue = ' ' queue_length = 0 endif endif C C Now validate format of form if specified. Field must not exceed 255 bytes. C If (print_form_length .gt. 255) then Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-BADLEN, form name is too long' Print *,'%MAILUAF-E-NOMODIFY, modify not performed' If (foreign_command ) then C (Force error condition to %SYSTEM-F-IVBUFLEN C and then abort program) status = ss$_ivbuflen call sys$exit(%val(status)) else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return endif endif C C Now validate format of forwarding name if specified. Field must not exceed C 255 bytes. C If (forwarding_name_length .gt. 255) then Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-BADLEN, forwarding name is too long' Print *,'%MAILUAF-E-NOMODIFY, modify not performed' If (foreign_command ) then C (Force error condition to %SYSTEM-F-IVBUFLEN C and then abort program) status = ss$_ivbuflen call sys$exit(%val(status)) else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return endif endif C C Now validate format of mail subdirectory if specified. Field must begin C with '[.' and end with ']'. C If (subdir_name_length .gt. 0) then If ((subdir_name(1:2) .ne. '[.') .or. + (subdir_name(subdir_name_length:subdir_name_length) + .ne. ']')) then C (Logic when invalid format specified) Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-NOTSUBDIR, parameter ', + subdir_name(1:subdir_name_length), + ' does not specify a subdirectory' Print *,'%MAILUAF-E-NOMODIFY, modify not performed' If (foreign_command ) then C (Force error condition to %SYSTEM-F-BADIRECTORY, bad directory C and then abort program) status = ss$_badirectory call sys$exit(%val(status)) else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return endif endif endif C C Now validate format of personal name if specified. C 1) Field must not exceed 255 bytes. C 2) First character must be alphabetic C 3) String cannot contain consecutive spaces C If (personal_name_length .gt. 255) then C Error logic if invalid length. Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-BADLEN, personal name is too long' Print *,'%MAILUAF-E-NOMODIFY, modify not performed' If (foreign_command ) then C (Force error condition to %SYSTEM-F-IVBUFLEN C and then abort program) status = ss$_ivbuflen call sys$exit(%val(status)) else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return endif endif If (personal_name_length .gt. 0) then ascii_value = ichar(personal_name(1:1)) If ((ascii_value .lt. 65) .or. + (ascii_value .gt. 90 .and. ascii_value .lt. 97) + .or. (ascii_value .gt. 122)) then C Error logic if first character isn't a valid uppercase or lowercase C letter. Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-BADFORMAT, 1st character of personal ', + 'name not alphabetic' Print *,'%MAILUAF-E-NOMODIFY, modify not performed' If (foreign_command ) then C (Force error condition to %SYSTEM-F-IVCHAR C and then abort program) status = ss$_ivchar call sys$exit(%val(status)) else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return endif endif endif If (personal_name_length .gt. 0) then Spaces_position = + str$position(personal_name(1:personal_name_length),' ') If (spaces_position .gt. zero) then C Error logic if consecutive spaces found in string. Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-BADFORMAT, personal name cannot have ', + 'multiple spaces' Print *,'%MAILUAF-E-NOMODIFY, modify not performed' If (foreign_command ) then C (Force error condition to %SYSTEM-F-IVCHAR C and then abort program) status = ss$_ivchar call sys$exit(%val(status)) else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return endif endif endif C C Now validate format of queue if specified. Field must not exceed 255 bytes. C If (queue_length .gt. 255) then Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-BADLEN, queue name is too long' Print *,'%MAILUAF-E-NOMODIFY, modify not performed' If (foreign_command ) then C (Force error condition to %SYSTEM-F-IVBUFLEN C and then abort program) status = ss$_ivbuflen call sys$exit(%val(status)) else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return endif endif C C Now build new record to replace old record in mail file. The layout of each C modified record is the following. The first 31 bytes contain the username. C Following the username field which is always 31 bytes are appended C a series of variable length fields. The variable data format is a C sequence of data fields in the following format: C Field type WORD C Field length WORD C Data STRING/WORD depending on field type C There are fifteen different field types. They are the following: C Value of Definition Data type based Optional field vs C Field Type of Field Type on Field Type required C ---------- --------------- --------------- ----------------- C 1 New mail count WORD required C 2 Flag field WORD required C 3 Mail subdirectory CHARACTER optional C 4 Forwarding name CHARACTER optional C 5 Personal name CHARACTER optional C 6 Mailplus cell CHARACTER optional C 7 Transport CHARACTER optional C 8 Mail editor CHARACTER optional C 9 Default queue CHARACTER optional C 10 User defined 1 CHARACTER optional C 11 User defined 2 CHARACTER optional C 12 User defined 3 CHARACTER optional C 13 Default form CHARACTER optional C 14 Spare 1 CHARACTER optional C 15 Spare 2 CHARACTER optional C C- Username new_mail_record(1:31) = user_text(1:user_length) C- New mail count - initialize to same value on record to be modified. field_type = 1 new_mail_record(32:33) = field_type_char field_length = 2 new_mail_record(34:35) = field_length_char field_text = newmail_count new_mail_record(36:37) = field_text_char C- Flag field C C Bit setting Meaning C ----------- ------- C 0000 0001 Copy-self on send C 0000 0010 Copy-self on reply C 0000 0100 Do not auto-purge C 0000 1000 Copy-self on forward C 0001 0000 Prompt for carbon-copy C field_type = 2 new_mail_record(38:39) = field_type_char field_length = 2 new_mail_record(40:41) = field_length_char flag_setting = 0 if (copy_send) flag_setting = iior(flag_setting,1) if (copy_reply) flag_setting = iior(flag_setting,2) if (.not. auto_purge) flag_setting = iior(flag_setting,4) if (copy_forward) flag_setting = iior(flag_setting,8) if (cc_prompt) flag_setting = iior(flag_setting,16) field_text = flag_setting new_mail_record(42:43) = field_text_char field_end = 43 C-Mail directory if (subdir_name_length .gt. 0) then field_begin = field_end + 1 field_end = field_begin + 1 field_type = 3 new_mail_record(field_begin:field_end) = field_type_char field_begin = field_end + 1 field_end = field_begin + 1 field_length = subdir_name_length new_mail_record(field_begin:field_end) = field_length_char field_begin = field_end + 1 field_end = field_end + subdir_name_length new_mail_record(field_begin:field_end) = subdir_name endif C-Forwarding name if (forwarding_name_length .gt. 0) then field_begin = field_end + 1 field_end = field_begin + 1 field_type = 4 new_mail_record(field_begin:field_end) = field_type_char field_begin = field_end + 1 field_end = field_begin + 1 field_length = forwarding_name_length new_mail_record(field_begin:field_end) = field_length_char field_begin = field_end + 1 field_end = field_end + forwarding_name_length new_mail_record(field_begin:field_end) = forwarding_name endif C-Personal name if (personal_name_length .gt. 0) then field_begin = field_end + 1 field_end = field_begin + 1 field_type = 5 new_mail_record(field_begin:field_end) = field_type_char field_begin = field_end + 1 field_end = field_begin + 1 field_length = personal_name_length new_mail_record(field_begin:field_end) = field_length_char field_begin = field_end + 1 field_end = field_end + personal_name_length new_mail_record(field_begin:field_end) = personal_name endif C-Editor if (editor_length .gt. 0) then field_begin = field_end + 1 field_end = field_begin + 1 field_type = 8 new_mail_record(field_begin:field_end) = field_type_char field_begin = field_end + 1 field_end = field_begin + 1 field_length = editor_length new_mail_record(field_begin:field_end) = field_length_char field_begin = field_end + 1 field_end = field_end + editor_length new_mail_record(field_begin:field_end) = editor endif C-Queue if (queue_length .gt. 0) then field_begin = field_end + 1 field_end = field_begin + 1 field_type = 9 new_mail_record(field_begin:field_end) = field_type_char field_begin = field_end + 1 field_end = field_begin + 1 field_length = queue_length new_mail_record(field_begin:field_end) = field_length_char field_begin = field_end + 1 field_end = field_end + queue_length new_mail_record(field_begin:field_end) = queue endif C-Print form if (print_form_length .gt. 0) then field_begin = field_end + 1 field_end = field_begin + 1 field_type = 13 new_mail_record(field_begin:field_end) = field_type_char field_begin = field_end + 1 field_end = field_begin + 1 field_length = print_form_length new_mail_record(field_begin:field_end) = field_length_char field_begin = field_end + 1 field_end = field_end + print_form_length new_mail_record(field_begin:field_end) = print_form endif C (Note the length of the new mail record just build) size = field_end C C If an editor type has been specified on the command line, make sure that C it is a valid editor type. All valid editor types are contained in the C directory sys$library. There should be a file in this directory called C '(editor name)shr.exe'. C If (editor_length .gt. 0) then editor_executable = 'sys$common:[syslib]' field_end = editor_length + 19 editor_executable(20:field_end) = editor field_begin = field_end + 1 field_end = field_end + 7 editor_executable(field_begin:field_end) = 'shr.exe' Inquire(file=editor_executable,exist=file_exists, + iostat=status) If (.not. file_exists) then C (Logic when not a valid editor type) Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-ERACTED, error activating editor ', + editor(1:editor_length) Print *,'%MAILUAF-E-OPENIN,error opening ', + 'sys$common:[syslib]',editor(1:editor_length), + 'shr.exe; as input' Print *,'%MAILUAF-E-NOMODIFY, modify not performed' If (foreign_command ) then C (Force error condition to %RMS-E-FNF,file not found C and then abort program) status = rms$_fnf call sys$exit(%val(status)) else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return endif endif endif If (subdir_name_length .eq. 0) goto 30 If (subdir_name .eq. old_subdir_name) goto 30 C C If mail directory was specified, create the mail directory. C Step 1: construct directory spec. C Step 2: issue system service call LIB$CREATE_DIR to create directory. C C First check to see if the default device and directory can be determined. C If no, then display error message and abort program. C If ((defdev_length .eq. 0) .or. (defdir_length .eq. 0)) then C (If this condition is true, the SYS$GETUAI system service C returned a rms$_rnf return code indicating that the specified C username is not on the sysuaf.dat file.) Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-NOFIND, user ',USER_TEXT(1:USER_LENGTH), + ' not found on sysuaf.dat file' Print *,'%MAILUAF-E-NODIRECTORY, cannot determine ', + 'directory name' Print *,'%MAILUAF-E-NOMODIFY, modify not performed' If (foreign_command ) then C (Force error condition to %RMS-E-RNF, record not found C and then abort program) status = rms$_rnf call sys$exit(%val(status)) else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return endif endif C C Now build a field containing the name of the device:[directory.subdirectory] C file spec. C Dev_dir_spec = defdev(2:defdev_length) Field_begin = defdev_length Field_end2 = defdir_length - 1 Field_end = field_begin + defdir_length - 3 Dev_dir_spec(field_begin:field_end) = defdir(2:field_end2) Field_begin = field_end + 1 Dev_dir_spec(field_begin:255) = + subdir_name(2:subdir_name_length) Call str$trim(dev_dir_spec,dev_dir_spec,dev_dir_spec_length) C C Create the mail subdirectory. Note, if the subdirectory already exists, the C system subroutine LIB$CREATE_DIR will return the ss$_normal status code. C Status = lib$create_dir(dev_dir_spec(1:dev_dir_spec_length), + 0,,,,) If (status .eq. ss$_created) then Print *,'%MAILUAF-I-CREATED, ', + dev_dir_spec(1:dev_dir_spec_length), + ' created' else If (status .eq. ss$_normal) then Print *,'%MAILUAF-I-EXISTS, ', + dev_dir_spec(1:dev_dir_spec_length), + ' already exists' else Call abort endif endif C C If the mail directory has been changed, move all files with .mai extension C to new mail directory. C 30 If (subdir_name .eq. old_subdir_name) goto 40 ! branch if no change If ((defdev_length .eq. 0) .or. (defdir_length .eq. 0)) then C (Display error message and take branch if uable to determine C default device or directory from sysuaf.dat) print *,'%MAILUAF-W-NOMOVE, unable to move *.mai;* files ', + 'to mail directory' print *,'- cannot determine default device or directory' goto 40 endif C C Make necessary preparations to rename the mail directory's *.mai files with C the system service call SYS$RENAME_FILE. First, create file spec referencing C the old record's mail directory *.mai;* files. C If (old_subdir_name_length .gt. 0) then C C (Logic for determining file spec when old records's mail directory C referred to a subdirectory.) C Old_mail_files_spec = defdev(2:defdev_length) Field_begin = defdev_length Field_end2 = defdir_length - 1 Field_end = field_begin + defdir_length - 3 Old_mail_files_spec(field_begin:field_end) = + defdir(2:field_end2) Field_begin = field_end + 1 Field_end = field_end + old_subdir_name_length - 1 Old_mail_files_spec(field_begin:255) = + old_subdir_name(2:old_subdir_name_length) field_begin = field_end + 1 old_spec_length = field_end + 7 old_mail_files_spec(field_begin:old_spec_length) = + '*.mai;*' else C C (Logic for determining file spec when old records's mail directory C referred to a main directory.) C old_mail_files_spec = defdev(2:defdev_length) field_begin = defdev_length field_end = field_begin + defdir_length - 2 old_mail_files_spec(field_begin:field_end) = + defdir(2:defdir_length) field_begin = field_end + 1 old_spec_length = field_end + 7 old_mail_files_spec(field_begin:old_spec_length) = + '*.mai;*' endif C C Now create file spec referencing the modified record's mail directory *.mai;* C files. C If (subdir_name_length .gt. 0) then C C (Logic for determining file spec when modified records's mail C directory refers to a subdirectory). C New_mail_files_spec = defdev(2:defdev_length) Field_begin = defdev_length Field_end2 = defdir_length - 1 Field_end = field_begin + defdir_length - 3 New_mail_files_spec(field_begin:field_end) = + defdir(2:field_end2) Field_begin = field_end + 1 Field_end = field_end + subdir_name_length - 1 New_mail_files_spec(field_begin:255) = + subdir_name(2:subdir_name_length) Field_begin = field_end + 1 New_spec_length = field_end + 7 New_mail_files_spec(field_begin:new_spec_length) = + '*.mai;*' else C C (Logic for determining file spec when modified records's mail C directory refers to main directory). C new_mail_files_spec = defdev(2:defdev_length) field_begin = defdev_length field_end = field_begin + defdir_length - 2 new_mail_files_spec(field_begin:field_end) = + defdir(2:defdir_length) field_begin = field_end + 1 new_spec_length = field_end + 7 new_mail_files_spec(field_begin:new_spec_length) = + '*.mai;*' endif Status = + lib$rename_file(old_mail_files_spec(1:old_spec_length), + new_mail_files_spec(1:new_spec_length)) If (status .eq. ss$_normal) then field_end = new_spec_length - 7 Print *,'%MAILUAF-I-MOVED, ', + '*.mai;* files moved to ', + new_mail_files_spec(1:field_end) else If (status .ne. rms$_fnf) call abort endif C C Now modify the record to the mail file C 40 Rewrite(1,'(a)',iostat=status) new_mail_record(1:size) If (status .ne. 0) call abort Print *,'%MAILUAF-I-MODIFY, user ',user_text(1:user_length), + ' was modified' Status = ss$_normal End Subroutine remove_user C C********************************************* C**** Logic invoked by the REMOVE command **** C********************************************* C Character*1 BELL Parameter (BELL= Char(7)) Integer*4 cli$get_value Character*31 User_text Integer*2 user_length Integer*4 status Logical*2 Foreign_command Character*2048 mail_record Integer*4 size Include '($foriosdef)' Include '($ssdef)' Include '($rmsdef)' Common status,foreign_command C C Get username value from command line. C Call cli$get_value('USER',user_text,user_length) C C User name was entered. Now read the record in mail file with this username C key. C Read(1,'(q,a)',key=user_text(1:user_length),keyid=0, + iostat=status) size,mail_record(1:size) If (status .eq. for$ios_attaccnon) then C (Logic when record not found in file) Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-NOFIND, user ',USER_TEXT(1:USER_LENGTH), + ' not found in mail file' Print *,'%MAILUAF-E-NOREMOVE, remove not performed' If (foreign_command ) then call abort ! abort pgm and display error message else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return endif else if (status .ne. 0) call abort !error has occurred, so abort program endif C C Now check to see if an exact key match was obtained. If no, then display C message and terminate program. C If (mail_record(1:31) .ne. user_text) then Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-NOFIND, user ',USER_TEXT(1:USER_LENGTH), + ' not found in mail file' Print *,'%MAILUAF-E-NOREMOVE, remove not performed' If (foreign_command ) then C (Force error condition to %RMS-E-RFN, record not found, and C abort program) status = rms$_rnf call sys$exit(%val(status)) else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return endif endif C C *** If you reach this point, record found on mail file. Now delete it. C Delete(1,iostat=status) If (status .ne. 0) call abort !error has occurred, so abort program Print *,'%MAILUAF-I-REMOVE, user ',user_text(1:user_length), + ' was removed from mail file' Status = ss$_normal End Subroutine show_user C C******************************************* C**** Logic invoked by the SHOW command **** C******************************************* C Character*1 BELL Parameter (BELL= Char(7)) Integer*4 sys$getuai Integer*4 str$trim External uai$_defdev External uai$_defdir Integer*4 cli$get_value Integer*4 lib$cvt_dx_dx Character*10 newmail_count_char Integer*2 new_mail_count_char_length Character*12 Usrnam Character*31 User_text Integer*2 user_length Integer*4 status Integer*4 size Logical*2 foreign_command Character*32 defdev Character*64 defdir Integer*4 defdev_length Integer*4 defdir_length Structure /itmlst/ Union Map Integer*2 buflen Integer*2 itmcod Integer*4 bufadr Integer*4 retadr End map Map Integer*4 end_list End map End union End structure C Record /itmlst/ getsysi_list(3) C Character*2048 mail_record Character*4 field_type_char Character*4 field_length_char Integer*2 field_type Integer*2 field_length Integer*2 field_begin Integer*2 field_end Character*2048 field_text_char Integer*2 field_text Integer*2 position Integer*2 newmail_count Integer*2 flags Integer*2 mask Integer*2 flag_setting Logical*2 copy_send Logical*2 copy_reply Logical*2 auto_purge Logical*2 copy_forward Logical*2 cc_prompt Character*80 flag_display Character*512 subdir_name Integer*2 subdir_name_length Character*512 forwarding_name Integer*2 forwarding_name_length Character*512 personal_name Integer*2 personal_name_length Character*512 mailplus_cell Integer*2 mailplus_cell_length Character*512 transport Integer*2 transport_length Character*512 editor Integer*2 editor_length Character*512 queue Integer*2 queue_length Character*512 user_defined1 Integer*2 user_defined1_length Character*512 user_defined2 Integer*2 user_defined2_length Character*512 user_defined3 Integer*2 user_defined3_length Character*512 print_form Integer*2 print_form_length Character*512 spare1 Integer*2 spare1_length Character*512 spare2 Integer*2 spare2_length Include '($ssdef)' Include '($rmsdef)' Include '($foriosdef)' Equivalence(field_type_char,field_type) Equivalence(field_length_char,field_length) Equivalence(field_text_char(1:2),field_text) Common status,foreign_command C C Get username value from command line. C Call cli$get_value('USER',user_text,user_length) C C User name was entered. Now read the record in mail file with this username C key. C Read(1,'(q,a)',key=user_text(1:user_length),keyid=0, + iostat=status) size,mail_record(1:size) If (status .eq. for$ios_attaccnon) then C (Logic when record not found in file) Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-NOFIND, user ',USER_TEXT(1:USER_LENGTH), + ' not found in mail file' Print *,'%MAILUAF-E-NOSHOW, show not performed' If (foreign_command ) then call abort ! abort pgm and display error message else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return endif else If (status .ne. 0) call abort !error has occurred,so abort program endif C C Now check to see if an exact key match was obtained. If no, then display C message and terminate program. C If (mail_record(1:31) .ne. user_text) then Print *,' ' Print *,Bell,Bell, + '%MAILUAF-E-NOFIND, user ',USER_TEXT(1:USER_LENGTH), + ' not found in mail file' Print *,'%MAILUAF-E-NOSHOW, show not performed' If (foreign_command ) then C (Force error condition to %RMS-E-RFN, record not found, and C abort program) status = rms$_rnf call sys$exit(%val(status)) else C (Give user another chance to correct problem. Therefore, C return to mainline.) status = ss$_normal return endif endif C C Determine the default device, default directory for the specified user C by issuing the system service call SYS$GETUAI. C Usrnam = user_text(1:user_length) Getsysi_list(1).buflen = 32 Getsysi_list(1).itmcod = %loc(uai$_defdev) Getsysi_list(1).bufadr = %loc(defdev) Getsysi_list(1).retadr = %loc(defdev_length) Getsysi_list(2).buflen = 64 Getsysi_list(2).itmcod = %loc(uai$_defdir) Getsysi_list(2).bufadr = %loc(defdir) Getsysi_list(2).retadr = %loc(defdir_length) Getsysi_list(3).end_list = 0 Status = sys$getuai(,,usrnam,getsysi_list,,,) C C If no user was found on sysuaf.dat, print error message and terminate C program. C If (status .eq. rms$_rnf) then defdev_length = 0 defdir_length = 0 else If (status .ne. ss$_normal) call abort endif If (defdev_length .gt. 0) + Call str$trim(defdev,defdev,defdev_length) If (defdir_length .gt. 0) + Call str$trim(defdir,defdir,defdir_length) C C Field initialization logic C copy_send = .false. copy_reply = .false. auto_purge = .true. copy_forward = .false. cc_prompt = .false. subdir_name_length = 0 forwarding_name_length = 0 personal_name_length = 0 editor_name_length = 0 queue_length = 0 print_form_length = 0 position = 32 C C *** If you reach this point, record found on mail file. Now analyze the C *** record's contents. Following the username field (length 31) are appended C *** a series of variable length fields. The variable data format is a C *** sequence of data fields in the following format: C Field type WORD C Field length WORD C Data STRING/WORD depending on field type C Do while (position .le. size) field_end = position + 1 field_type_char = mail_record(position:field_end) field_begin = position + 2 field_end = position + 3 field_length_char = mail_record(field_begin:field_end) field_begin = position + 4 field_end = field_begin + field_length - 1 field_text_char = mail_record(field_begin:field_end) position = field_end + 1 If (field_type .eq. 1) then C (If true, then data field contains value of new mail count) newmail_count = field_text goto 20 endif If (field_type .eq. 2) then C (If true, then data field is the flag field) flags = field_text C C Now analyze the bit settings in flag field C C Bit setting Meaning C ----------- ------- C 0000 0001 Copy-self on send C 0000 0010 Copy-self on reply C 0000 0100 Do not auto-purge C 0000 1000 Copy-self on forward C 0001 0000 Prompt for carbon-copy C mask = 1 flag_setting = iiand(field_text,mask) if (flag_setting .eq. 1) copy_send = .true. mask = 2 flag_setting = iiand(field_text,mask) if (flag_setting .eq. 2) copy_reply = .true. mask = 4 flag_setting = iiand(field_text,mask) if (flag_setting .eq. 4) auto_purge = .false. mask = 8 flag_setting = iiand(field_text,mask) if (flag_setting .eq. 8) copy_forward = .true. mask = 16 flag_setting = iiand(field_text,mask) if (flag_setting .eq. 16) cc_prompt = .true. goto 20 endif If (field_type .eq. 3) then C (If true, then data field contains value of mail subdirectory name) subdir_name = field_text_char subdir_name_length = field_length goto 20 endif If (field_type .eq. 4) then C (If true, then data field contains value of forwarding name) forwarding_name = field_text_char forwarding_name_length = field_length goto 20 endif If (field_type .eq. 5) then C (If true, then data field contains value of personal name) personal_name = field_text_char personal_name_length = field_length goto 20 endif If (field_type .eq. 6) then C (If true, then data field contains value of mailplus cell) mailplus_cell = field_text_char mailplus_cell_length = field_length goto 20 endif If (field_type .eq. 7) then C (If true, then data field contains value of transport) transport = field_text_char transport_length = field_length goto 20 endif If (field_type .eq. 8) then C (If true, then data field contains value of mail editor) editor = field_text_char editor_length = field_length goto 20 endif If (field_type .eq. 9) then C (If true, then data field contains value of default queue name) queue = field_text_char queue_length = field_length goto 20 endif If (field_type .eq. 10) then C (If true, then data field contains value of user defined field 1) user_defined1 = field_text_char user_defined1_length = field_length goto 20 endif If (field_type .eq. 11) then C (If true, then data field contains value of user defined field 2) user_defined2 = field_text_char user_defined2_length = field_length goto 20 endif If (field_type .eq. 12) then C (If true, then data field contains value of user defined field 3) user_defined3 = field_text_char user_defined3_length = field_length goto 20 endif If (field_type .eq. 13) then C (If true, then data field contains value of default print form) print_form = field_text_char print_form_length = field_length goto 20 endif If (field_type .eq. 14) then C (If true, then data field contains value of spare field 1) spare1 = field_text_char spare1_length = field_length goto 20 endif If (field_type .eq. 15) then C (If true, then data field contains value of spare field 2) spare2 = field_text_char spare2_length = field_length goto 20 endif 20 end do C C Now display the record's contents. C Print *,' ' C - Display USERNAME Print *,'Username is ',user_text(1:user_length),'.' C - Display NEW MAIL MESSAGE COUNT C (First convert new mail message count to string variable before C displaying.) Status = lib$cvt_dx_dx(%descr(newmail_count), + %descr(newmail_count_char), + %ref(newmail_count_char_length)) If (.not. status) then call lib$signal(%val(status)) call sys$exit(%val(status)) endif If (newmail_count .eq. 1) then print *, '1 new mail message.' else If (newmail_count .gt. 0) then print *, Newmail_count_char(1:newmail_count_char_length), + ' new mail messages.' else print *,'0 new mail messages.' endif endif C - Display file spec of MAIL DIRECTORY If ((defdev_length .eq. 0) .or. (defdir_length .eq. 0)) then if (subdir_name_length .gt. 0) + print *,'Mail directory is ', + subdir_name(1:subdir_name_length) if (subdir_name_length .eq. 0) + print *,'No mail directory is defined.' else if (subdir_name_length .gt. 0) then field_end = defdir_length - 1 print *,'Mail directory is ',defdev(2:defdev_length), + defdir(2:field_end), + subdir_name(2:subdir_name_length) else print *,'Mail directory is ',defdev(2:defdev_length), + defdir(2:defdir_length) endif endif C Display FORWARDING NAME If (forwarding_name_length .gt. 0) then print * ,'Mail is being forwarded to ', + forwarding_name(1:forwarding_name_length),'.' else print *,'No forwarding address is set.' endif C Display PERSONAL NAME If (personal_name_length .gt. 0) then print *,'Personal name is "', + personal_name(1:personal_name_length),'".' else print *,'No personal name is set.' endif C Display EDITOR name If (editor_length .gt. 0) then print *,'Mail editor is ',editor(1:editor_length),'.' else print *,'Mail editor is EDT.' endif C Display QUEUE name If (queue_length .gt. 0) then print *,'Default print queue is ', + queue(1:queue_length),'.' else print *,'Default print queue is SYS$PRINT.' endif C Display print FORM name If (print_form_length .gt. 0) then print *,'Default print form is ', + print_form(1:print_form_length),'.' else print *,'No default print form is specified.' endif C Display flag settings If (copy_send) then print *,'Automatic copies on send is enabled','.' else print *,'Automatic copies on send is disabled','.' endif If (copy_reply) then print *,'Automatic copies on reply is enabled','.' else print *,'Automatic copies on reply is disabled','.' endif If (auto_purge) then print *,'Automatic deleted message purge is enabled','.' else print *,'Automatic deleted message purge is disabled','.' endif If (copy_forward) then print *,'Automatic copies on forward is enabled','.' else print *,'Automatic copies on forward is disabled','.' endif If (cc_prompt) then print *,'CC prompting is enabled','.' else print *,'CC prompting is disabled','.' endif status = ss$_normal end Subroutine list_users C C******************************************* C**** Logic invoked by the LIST command **** C******************************************* C Character*1 BELL Parameter (BELL= Char(7)) Integer*4 sys$getuai Integer*4 str$trim Integer*4 lib$cvt_dx_dx Character*10 newmail_count_char Integer*2 new_mail_count_char_length External uai$_defdev External uai$_defdir Integer*4 cli$present External cli$_present External cli$_absent Character*12 Usrnam Character*31 User_text Integer*2 user_length Integer*4 status Integer*4 size Logical*2 foreign_command Character*32 defdev Character*64 defdir Integer*4 defdev_length Integer*4 defdir_length Structure /itmlst/ Union Map Integer*2 buflen Integer*2 itmcod Integer*4 bufadr Integer*4 retadr End map Map Integer*4 end_list End map End union End structure C Record /itmlst/ getsysi_list(3) C Character*2048 mail_record Character*4 field_type_char Character*4 field_length_char Integer*2 field_type Integer*2 field_length Integer*2 field_begin Integer*2 field_end Character*2048 field_text_char Integer*2 field_text Integer*2 position Integer*2 newmail_count Integer*2 flags Integer*2 mask Integer*2 flag_setting Logical*2 copy_send Logical*2 copy_reply Logical*2 auto_purge Logical*2 copy_forward Logical*2 cc_prompt Character*80 flag_display Character*512 subdir_name Integer*2 subdir_name_length Character*512 forwarding_name Integer*2 forwarding_name_length Character*512 personal_name Integer*2 personal_name_length Character*512 mailplus_cell Integer*2 mailplus_cell_length Character*512 transport Integer*2 transport_length Character*512 editor Integer*2 editor_length Character*512 queue Integer*2 queue_length Character*512 user_defined1 Integer*2 user_defined1_length Character*512 user_defined2 Integer*2 user_defined2_length Character*512 user_defined3 Integer*2 user_defined3_length Character*512 print_form Integer*2 print_form_length Character*512 spare1 Integer*2 spare1_length Character*512 spare2 Integer*2 spare2_length Logical*2 brief_display Logical*2 full_display Include '($ssdef)' Include '($rmsdef)' Include '($foriosdef)' Equivalence(field_type_char,field_type) Equivalence(field_length_char,field_length) Equivalence(field_text_char(1:2),field_text) Common status,foreign_command C C Determine if brief display or full display has been requested. Brief display C is considered the default display if no particular display type is specified C on the command line. C Status = cli$present('FULL') If (status .eq. %loc(cli$_present)) then full_display = .true. brief_display = .false. else full_display = .false. brief_display = .true. print *,'Username Forwarding address' print *,'-------- ------------------' endif C C Read each record of mail file. C 10 Read(1,'(q,a)',end=9999,iostat=status) size,mail_record(1:size) If (status .ne. 0) call abort C C Determine the username in record. C User_text = mail_record(1:31) Call str$trim(user_text,user_text,user_length) C C Field initialization logic C copy_send = .false. copy_reply = .false. auto_purge = .true. copy_forward = .false. cc_prompt = .false. subdir_name_length = 0 forwarding_name_length = 0 personal_name_length = 0 editor_name_length = 0 queue_length = 0 print_form_length = 0 position = 32 C C *** If you reach this point, record found on mail file. Now analyze the C *** record's contents. Following the username field (length 31) are appended C *** a series of variable length fields. The variable data format is a C *** sequence of data fields in the following format: C Field type WORD C Field length WORD C Data STRING/WORD depending on field type C Do while (position .le. size) field_end = position + 1 field_type_char = mail_record(position:field_end) field_begin = position + 2 field_end = position + 3 field_length_char = mail_record(field_begin:field_end) field_begin = position + 4 field_end = field_begin + field_length - 1 field_text_char = mail_record(field_begin:field_end) position = field_end + 1 If (field_type .eq. 1) then C (If true, then data field contains value of new mail count) newmail_count = field_text goto 20 endif If (field_type .eq. 2) then C (If true, then data field is the flag field) flags = field_text C C Now analyze the bit settings in flag field C C Bit setting Meaning C ----------- ------- C 0000 0001 Copy-self on send C 0000 0010 Copy-self on reply C 0000 0100 Do not auto-purge C 0000 1000 Copy-self on forward C 0001 0000 Prompt for carbon-copy C mask = 1 flag_setting = iiand(field_text,mask) if (flag_setting .eq. 1) copy_send = .true. mask = 2 flag_setting = iiand(field_text,mask) if (flag_setting .eq. 2) copy_reply = .true. mask = 4 flag_setting = iiand(field_text,mask) if (flag_setting .eq. 4) auto_purge = .false. mask = 8 flag_setting = iiand(field_text,mask) if (flag_setting .eq. 8) copy_forward = .true. mask = 16 flag_setting = iiand(field_text,mask) if (flag_setting .eq. 16) cc_prompt = .true. goto 20 endif If (field_type .eq. 3) then C (If true, then data field contains value of mail subdirectory) subdir_name = field_text_char subdir_name_length = field_length goto 20 endif If (field_type .eq. 4) then C (If true, then data field contains value of forwarding name) forwarding_name = field_text_char forwarding_name_length = field_length goto 20 endif If (field_type .eq. 5) then C (If true, then data field contains value of personal name) personal_name = field_text_char personal_name_length = field_length goto 20 endif If (field_type .eq. 6) then C (If true, then data field contains value of mailplus cell) mailplus_cell = field_text_char mailplus_cell_length = field_length goto 20 endif If (field_type .eq. 7) then C (If true, then data field contains value of transport) transport = field_text_char transport_length = field_length goto 20 endif If (field_type .eq. 8) then C (If true, then data field contains value of mail editor) editor = field_text_char editor_length = field_length goto 20 endif If (field_type .eq. 9) then C (If true, then data field contains value of default queue name) queue = field_text_char queue_length = field_length goto 20 endif If (field_type .eq. 10) then C (If true, then data field contains value of user defined field 1) user_defined1 = field_text_char user_defined1_length = field_length goto 20 endif If (field_type .eq. 11) then C (If true, then data field contains value of user defined field 2) user_defined2 = field_text_char user_defined2_length = field_length goto 20 endif If (field_type .eq. 12) then C (If true, then data field contains value of user defined field 3) user_defined3 = field_text_char user_defined3_length = field_length goto 20 endif If (field_type .eq. 13) then C (If true, then data field contains value of default print form) print_form = field_text_char print_form_length = field_length goto 20 endif If (field_type .eq. 14) then C (If true, then data field contains value of spare field 1) spare1 = field_text_char spare1_length = field_length goto 20 endif If (field_type .eq. 15) then C (If true, then data field contains value of spare field 2) spare2 = field_text_char spare2_length = field_length goto 20 endif 20 end do C C If brief display then just display ther username and forwarding address C If (brief_display) then if (forwarding_name_length .gt. 0) then write (*,'(1x,a,t34,a)') user_text(1:user_length), + forwarding_name(1:forwarding_name_length) else write (*,'(1x,a)') user_text(1:user_length) endif goto 10 endif C C Full display has been requested so display the entire record contents. C C C Determine the default device, default directory for the specified user C by issuing the system service call SYS$GETUAI. C Usrnam = user_text(1:user_length) Getsysi_list(1).buflen = 32 Getsysi_list(1).itmcod = %loc(uai$_defdev) Getsysi_list(1).bufadr = %loc(defdev) Getsysi_list(1).retadr = %loc(defdev_length) Getsysi_list(2).buflen = 64 Getsysi_list(2).itmcod = %loc(uai$_defdir) Getsysi_list(2).bufadr = %loc(defdir) Getsysi_list(2).retadr = %loc(defdir_length) Getsysi_list(3).end_list = 0 Status = sys$getuai(,,usrnam,getsysi_list,,,) C C If user not found in sysuaf.dat, ignore that record C If (status .eq. rms$_rnf) then defdev_length = 0 defdir_length = 0 else If (status .ne. ss$_normal) call abort endif If (defdev_length .gt. 0) + Call str$trim(defdev,defdev,defdev_length) If (defdir_length .gt. 0) + Call str$trim(defdir,defdir,defdir_length) Print *,' ' C - Display USERNAME Print *,'Username is ',user_text(1:user_length),'.' C - Display NEW MAIL MESSAGE COUNT C (First convert new mail message count to string variable before C displaying.) Status = lib$cvt_dx_dx(%descr(newmail_count), + %descr(newmail_count_char), + %ref(newmail_count_char_length)) If (.not. status) then call lib$signal(%val(status)) call sys$exit(%val(status)) endif If (newmail_count .eq. 1) then print *, '1 new mail message.' else If (newmail_count .gt. 0) then print *, Newmail_count_char(1:newmail_count_char_length), + ' new mail messages.' else print *,'0 new mail messages.' endif endif C - Display file spec of MAIL DIRECTORY If ((defdev_length .eq. 0) .or. (defdir_length .eq. 0)) then if (subdir_name_length .gt. 0) + print *,'Mail directory is ', + subdir_name(1:subdir_name_length) if (subdir_name_length .eq. 0) + print *,'No mail directory is defined.' else if (subdir_name_length .gt. 0) then field_end = defdir_length - 1 print *,'Mail directory is ',defdev(2:defdev_length), + defdir(2:field_end), + subdir_name(2:subdir_name_length) else print *,'Mail directory is ',defdev(2:defdev_length), + defdir(2:defdir_length) endif endif C Display FORWARDING NAME If (forwarding_name_length .gt. 0) then print * ,'Mail is being forwarded to ', + forwarding_name(1:forwarding_name_length),'.' else print *,'No forwarding address is set.' endif C Display PERSONAL NAME If (personal_name_length .gt. 0) then print *,'Personal name is "', + personal_name(1:personal_name_length),'".' else print *,'No personal name is set.' endif C Display EDITOR name If (editor_length .gt. 0) then print *,'Mail editor is ',editor(1:editor_length),'.' else print *,'Mail editor is EDT.' endif C Display QUEUE name If (queue_length .gt. 0) then print *,'Default print queue is ', + queue(1:queue_length),'.' else print *,'Default print queue is SYS$PRINT.' endif C Display print FORM name If (print_form_length .gt. 0) then print *,'Default print form is ', + print_form(1:print_form_length),'.' else print *,'No default print form is specified.' endif C Display flag settings If (copy_send) then print *,'Automatic copies on send is enabled','.' else print *,'Automatic copies on send is disabled','.' endif If (copy_reply) then print *,'Automatic copies on reply is enabled','.' else print *,'Automatic copies on reply is disabled','.' endif If (auto_purge) then print *,'Automatic deleted message purge is enabled','.' else print *,'Automatic deleted message purge is disabled','.' endif If (copy_forward) then print *,'Automatic copies on forward is enabled','.' else print *,'Automatic copies on forward is disabled','.' endif If (cc_prompt) then print *,'CC prompting is enabled','.' else print *,'CC prompting is disabled','.' endif goto 10 9999 status = ss$_normal end Subroutine abort C This subroutine provides a meaningful message identifying what error C has occurred Integer*4 status Logical*2 foreign_command Integer*4 rmssts ! RMS completion status code Integer*4 rmsstv ! RMS status value Integer*4 condval ! actual VAX condition value Common status,foreign_command C C*** This subroutine is a Fortran system subroutine which returns information C*** about the most recent error Close(1) Call ERRSNS (,rmssts, rmsstv,, condval) If (rmssts .ne. 0) then status = rmssts Else if (rmsstv .ne. 0) then status = rmsstv Else status = condval Endif Call SYS$EXIT(%VAL(status)) ! exit to VMS with message End