Source Code 1992 March

home *** CD-ROM | disk | FTP | other *** search

/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / usenet / altsrcs / 3 / 3986 < prev next >

Wrap

Internet Message Format | 1991-09-09 | 14.7 KB

Path: wupost!uunet!europa.asd.contel.com!darwin.sura.net!noc.sura.net!haven.umd.edu!mimsy!nrlvx1.nrl.navy.mil!koffley From: koffley@nrlvx1.nrl.navy.mil Newsgroups: alt.sources Subject: VMS UAF PROFILE part 12 of 18 Message-ID: <1991Sep5.074608.556@nrlvx1.nrl.navy.mil> Date: 5 Sep 91 11:46:08 GMT Organization: NRL SPACE SYSTEMS DIVISION Lines: 474 -+-+-+-+-+-+-+-+ START OF PART 12 -+-+-+-+-+-+-+-+ X if (.not. user_exists) then X call smg$put_chars ( main, X . 'Account has been added', 21, 1 ) X elseif (user_exists) then X call smg$put_chars ( main, X . 'Account has been modified', 21, 1 ) X endif XC XC Check to see if the toplevel directory already exists. If it does, XC return to the main program. XC X if (.not.user_exists) then X inquire (file=main_dev(1:offset-1)//':`5B0,0`5D'// X . defdir(index(defdir,'`5B')+1:index(defdir,'`5D')-1)// X . '.DIR;1',exist=directory_exists) X if (.not.directory_exists) then XC XC Create the toplevel directory using LIB$CREATE_DIR. It might be a XC good idea to enable BYPASS and/or EXQUOTA privilege to ensure that XC the directory is created, so we can do that now. If you do not want XC to use this feature, delete the following lines of code. XC XC Make a call to $SETPRV to set some needed privileges in case this XC program is being run from an account which does not have all XC privileges enabled. XC X sts = sys$setprv ( %val(enbflg), priv_mask ,, ) X if (.not.sts) call lib$signal ( %val(sts) ) XC XC Get the directory spec string to pass to LIB$CREATE_DIR XC X dir_spec = defdev(1:defdev_len)//':'// X . defdir(1:defdir_len) X spec_len = index(dir_spec,' ')-1 XC XC Make the call to LIB$CREATE_DIR to create the user directory XC X call lib$create_dir ( dir_spec(1:spec_len), uic_value ) X endif XC XC If you do not want to copy a sample login.com to the user directory, XC remove the following line. XC X call copy ( dir_spec(1:spec_len) ) X else X return X endif X X end X XC************************************************************************ X X Subroutine COPY ( dir_spec ) XC XC The purpose of this subroutine is to copy a sample login.com file XC to the directory of the new user. If you do not want to use this XC option, remove the entire subroutine. If you do want to use this XC routine, modify the character string 'infile' to specify the location XC and name of the sample login file. This copy routine uses the XC CONVERT utility. XC X Integer*4 conv$pass_files, conv$pass_options, conv$convert X Integer*4 option /0/ X Integer*4 stsblk(5) /4,0,0,0,0/ X Character*40 infile ! Modify this X . /'SYS$SYSROOT:`5BSYSMGR.COM`5DSAMPLE_LOGIN.COM'/ ! character stri Vng X Character*80 outfile X Character*(*) dir_spec X X outfile = dir_spec//'LOGIN.COM' X X call conv$pass_files ( infile, outfile ) X call conv$pass_options ( option ) X call conv$convert ( stsblk ) X X end X XC************************************************************************ X X Subroutine SENDMAIL XC XC This subroutine will send a brief welcome message to the new user. If XC you have no interest in doing this, you should delete this routine. XC XC If the file SYS$LOGIN:NEWUSER.TXT exists, it will be sent to the user. XC If the file doesn't exist, a short default message file will be created XC and that will be sent. You may wish to create a NEWUSER.TXT to place in XC your home directory. This file could contain general user information XC and site policy, etc. XC XC - JMH XC X Include 'uaf.cmn' X Include 'maildef.inc' X Include '($syidef)' X Character*10 subject X`09Character*20 node X`09Integer*4 lib$getsyi X`09Integer node_len, send_ctx X`09Logical file_exists X X structure /itemlist/ X integer*2 len X integer*2 item_code X integer*4 address X integer*4 retlen X end structure X X record /itemlist/ msg_info(2), null, body(2), address(2),`20 X . create(2) XC XC get the nodename`20 XC X`09call lib$getsyi ( syi$_nodename ,, node, node_len ) X`09if (node .eq. ' ') node = 'the system' X X`09subject = 'Welcome' ! change this line to suit your purpose XC XC look for a file called NEWUSER.TXT in your home directory. If it XC doesn't exist, a file will be created. XC X`09inquire (file='SYS$LOGIN:NEWUSER.TXT', exist=file_exists) X`09if (.not. file_exists) then X open (unit=1, status='new', file='SYS$LOGIN:NEWUSER.TXT') X`09 write (1,'(a)') 'Greetings,' X`09 write (1,'(a)') ' ' X write (1,'(a)')`20 X . 'You now have an account on ' // node(1:node_len) // X . '. If you have any' X write (1,'(a)')`20 X . 'questions, please contact me at the above email address.' X write (1,'(a)') ' ' X write (1,'(a)') 'Thank you and welcome aboard!' X close (1) X endif X X call mail_setup ( address, mail$_send_username,`20 X . username(1:username_len), ) X call mail_setup ( msg_info, mail$_send_subject, subject, ) X call mail_setup ( body, mail$_send_filename,`20 X . 'SYS$LOGIN:NEWUSER.TXT', ) X X call mail$send_begin ( send_ctx, null, null ) X call mail$send_add_attribute ( send_ctx, msg_info, null ) X call mail$send_add_bodypart ( send_ctx, body, null ) X call mail$send_add_address ( send_ctx, address, null ) X call mail$send_message ( send_ctx, null, null ) X call mail$send_end ( send_ctx, null, null ) X X`09end X XC************************************************************************ X X Subroutine MAIL_SETUP ( item, code, string, ret_len ) XC XC This subroutine is called in order to set up the itemlists needed by XC the main program XC X character*(*) string X integer ret_len X integer code X X structure /itemlist/ X integer*2 len X integer*2 item_code X integer*4 address X integer*4 retlen X end structure X X record /itemlist/ item X X item.len = len(string) X item.item_code = code X item.address = %loc(string) X item.retlen = %loc(ret_len) X X end X Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc X X X`09subroutine repeat (char_variable, fill_char) X X X`09character*(*) char_variable X`09character*1 fill_char X X`09do i = 1, len(char_variable) X`09 char_variable(i:i) = fill_char X`09enddo X X`09return X`09end X X Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc X X X`09subroutine show_rights X X Include 'uaf.cmn' X`09include '($SSDEF)' X`09include '($LIBDEF)' X`09include '($UAIDEF)' X Integer*4 line, col, i, j, SYS$FIND_HELD , SYS$IDTOASC`20 X Character*25 string X X`09integer*4 holder_uic (2), ident_value X`09integer*4 identifier, attrib_mask, context, status, name_Len X`09character*132 char_buffer X`09character*40 char_rights (100) X X`09external SYS$FIND_HELD, SYS$IDTOASC`20 X X X X X`09holder_uic (1) = uic_value Xd`09write (66,'(1x,z8)' ) uic_value Xd`09write (66,*) pasteboard X X`09context = 0 X`09attrib_mask = 0 X`09holder_uic (2) = 0 X`09num_rights = 0 X X`09do while (.true.) X`09 status = SYS$FIND_HELD (holder_uic(1), identifier, attrib_mask,`20 X`091 context) X`09 if (.not. status) then X`09 if (status .eq. SS$_NOSUCHID) then X`09 call SYS$FINISH_RDB (context) X`09 goto 1000 X`09 else X`09 call SYS$FINISH_RDB (context) X`09 call LIB$SIGNAL (%val(status)) X`09 endif X X`09 else Xd`09 write (6,*) 'FIND_HELD is OK , identifier= ',identifier X`09 status = SYS$IDTOASC (%val(identifier), namelen, char_buffer, X`091 ident_value, attrib_mask, new_context) X`09 if (.not. status) then X`09 call SYS$FINISH_RDB (context) X`09 call lib$signal(%val(status)) X`09 goto 1000 X`09 else X`09 num_rights = num_rights + 1 X`09 char_rights (num_rights) = char_buffer(1:namelen) Xd`09 write (6,*) char_buffer(1:namelen) X`09 endif X X`09 endif X X`09enddo X X1000`09call DISPLAY_RIGHTS (char_rights, num_rights) X X`09return X`09end X Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc X X X`09integer*4 function LEFT_JUSTIFY (source) X X`09include '($strdef)' X X`09character*(*) source X`09character*132 dest X`09integer*4 length, start X X`09call str$trim (dest, source, length) X`09call repeat (source, ' ') Xc Xc ---`09Remove any leading blanks or nulls Xc X`09do i = 1, length X`09 if ((dest(i:i) .ne. ' ') .and. dest(i:i) .ne. char(0)) then X`09 start = i X`09 goto 3 X`09 endif X`09enddo X X3`09call str$len_extr (source, dest, start, length-start+1) X`09call repeat (dest, ' ') X`09call str$trim (source, source, length) Xd`09write (66,4) source, length X4`09format (1x,'dest strng = 'a<length>,/,1x,'Contains ',i2,' chars.') X`09left_justify = length X X`09return X`09end X X Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc X X`09integer function LEN_TRIM (string) Xc Xc Function to return length of string to last non-blank, non-null character Xc Xc Form of call:`09length = len_trim(string) Xc Xc Where`09length`09is the returned integer length Xc`09`09string`09is the character string Xc X character*(*) string X X do i=len(string),1,-1 X if(string(i:i).ne.' ')then X`09`09if(string(i:i).ne.char(0))then X`09`09 goto 10 X`09`09endif X`09 endif X`09enddo X X10 len_trim=i X X return X end X Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc X X`09subroutine DISPLAY_RIGHTS (char_rights, num_rights) X X`09implicit none X`09include 'uaf.cmn' X`09include '($TRMDEF)' X`09include '($SMGDEF)' X X`09integer*4 rows, cols, status, disp1, modifiers, mask, i, kilo, X`091 num_scroll_lines, num, current_line, num_rights, X`092 length, left_justify, max_chars X X`09integer*2 terminator X X`09character*1 input_string X`09character*(*) char_rights (*) X X X X X`09rows = num_rights + 2 ! make as large as number of total items in`20 X`09`09`09`09! scroll buffer X`09 `09`09! plus (number of scroll lines displayed - 1) X`09cols = 40 X X`09call SMG$ERASE_DISPLAY (message) X call SMG$PUT_CHARS ( message, X . 'Use arrow keys/NEXT/PREV or keypad to scroll.', X . 1, 2 ) X call SMG$PUT_CHARS ( message, X . 'ControlZ: exit to main display.', X . 2, 2 ) X call smg$paste_virtual_display ( message, pasteboard, 22, 1 ) X`09call SMG$CREATE_VIRTUAL_DISPLAY (rows, cols, disp1, SMG$M_BORDER) X`09call SMG$LABEL_BORDER (disp1, ' RIGHTS ') X Xc ---`09The "3" is the number of scroll lines displayed X`09call SMG$CREATE_VIEWPORT (disp1, 1, 1, 3, 40) X X`09if (num_rights .eq. 0) then X`09 char_rights(1) = 'No Rights Held' X`09 num_rights = 1 X`09endif X X`09do i = 1, num_rights X`09 length = left_justify (char_rights(i)) X`09 call CENTER_STRING (char_rights(i), 40, status) X`09 call SMG$PUT_CHARS (disp1, char_rights(i), i, 1) X`09enddo X X`09call SMG$PASTE_VIRTUAL_DISPLAY (disp1, pasteboard, 10, 20) Xc Xc ---`09Set smooth scrolling Xc X`09mask = 0 X`09mask = SMG$M_SCROLL_SMOOTH + SMG$M_CURSOR_OFF X X`09call SMG$SET_CURSOR_MODE (pasteboard, mask) X X`09call SMG$HOME_CURSOR (disp1, SMG$C_UPPER_LEFT) X X`09modifiers = TRM$M_TM_ESCAPE .or. TRM$M_TM_NOECHO .or. TRM$M_TM_PURGE X`09max_chars = 6 X`09status = SMG$READ_STRING (keyboard, input_string, ,max_chars,`20 X`091 modifiers,,,, terminator) X X`09num_scroll_lines = 2 X`09current_line = 1 X X`09do while (status) X X`09 if (.not. status) call LIB$SIGNAL(%val(status)) X X`09 if ((terminator .eq. SMG$K_TRM_KP8) .or. X`091 (terminator .eq. SMG$K_TRM_UP) .or. X`092 (terminator .eq. SMG$K_TRM_NEXT_SCREEN)) then X`09 num = current_line + num_scroll_Lines X`09 if (num .gt. num_rights) then X`09 num = num_rights - current_line X`09 current_line = num_rights X`09 else X`09 current_line = num X`09 num = num_scroll_lines X`09 endif X`09 do i = 1, num X`09 call SMG$SCROLL_VIEWPORT (disp1, SMG$M_UP, 1) X`09 enddo X`09 elseif ((terminator .eq. SMG$K_TRM_KP2) .or. X`091 (terminator .eq. SMG$K_TRM_DOWN).or. X`092 (terminator .eq. SMG$K_TRM_PREV_SCREEN)) then X`09 num = current_line - num_Scroll_Lines X`09 if (num .lt. 1) then X`09 num = current_line - 1 X`09 current_line = 1 X`09 else X`09 current_line = num X`09 num = num_scroll_lines X`09 endif X`09 do i = 1, num X`09 call SMG$SCROLL_VIEWPORT (disp1, SMG$M_DOWN, 1) X`09 enddo X X elseif ((terminator.eq.smg$k_trm_ctrlz) .or. X`091 (terminator .eq. SMG$K_TRM_CR)) then X`09 goto 1000 X X elseif (terminator.eq.smg$k_trm_ctrlw) then X call smg$repaint_screen ( pasteboard ) X X`09 endif X X`09 status = SMG$READ_STRING (keyboard, input_string, ,max_chars,`20 X`091 modifiers,,,, terminator) X`09enddo X X1000`09mask = 0 X`09mask = SMG$M_SCROLL_JUMP + SMG$M_CURSOR_ON X +-+-+-+-+-+-+-+- END OF PART 12 +-+-+-+-+-+-+-+- -- \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/ < Joe Koffley KOFFLEY@NRLVAX.NRL.NAVY.MIL > < Naval Research Laboratory KOFFLEY@CCF.NRL.NAVY.MIL > < Space Systems Division AT&T : 202-767-0894 > \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/