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 / 3987 < prev next >

Wrap

Internet Message Format | 1991-09-09 | 14.6 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 13 of 18 Message-ID: <1991Sep5.074634.557@nrlvx1.nrl.navy.mil> Date: 5 Sep 91 11:46:34 GMT Organization: NRL SPACE SYSTEMS DIVISION Lines: 538 -+-+-+-+-+-+-+-+ START OF PART 13 -+-+-+-+-+-+-+-+ X`09call SMG$SET_CURSOR_MODE (pasteboard, mask) X`09call SMG$UNPASTE_VIRTUAL_DISPLAY (disp1, pasteboard) X X`09return X`09end X X X X Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc X X X`09subroutine SHOW_LASTLOGIN X X X Include 'uaf.cmn' X Include '($smgdef)' X Integer*4 line, col, i, j X Character*25 string X X bogus_key = .true. X XC XC Reset line and column values. XC X line = 3 X col = 25 XC XC Write instructions to the message window XC X`09call smg$erase_display (message) X call smg$erase_display ( login_board ) X call smg$put_chars ( login_board, ' Last Interactive Login: ', X . 1, 2 ,, smg$m_bold ) X call smg$put_chars ( login_board, char_last_login_i, X . 1, 31 ,, ) X call smg$put_chars ( login_board, ' Last Non-Interactive Login: ', X . 2, 2 ,, smg$m_bold ) X call smg$put_chars ( login_board, char_last_Login_n, X . 2, 31 ,, ) X X X call smg$put_chars ( message, X . 'ControlZ: exit to main display.', X . 1, 2 ) X call smg$put_chars ( message, X . 'Show Login Port Info: ', X . 2, 2 ) X call smg$put_chars ( message, ' <PF1> ', X . 2, 24 ,, smg$m_bold ) XC XC Paste virtual displays, end the pasteboard update, and set the cursor XC to the first position XC X call smg$paste_virtual_display ( login_board, pasteboard, 12,10 ) X call smg$paste_virtual_display ( message, pasteboard, 22, 1 ) X call smg$set_cursor_abs ( login_board, line, col ) XC XC Read a keystroke. Loop until terminator key is hit (ctrlZ). XC X do while (bogus_key) X call smg$read_keystroke ( keyboard, term ) XC XC CtrlW - repaint screen XC X if (term.eq.smg$k_trm_ctrlw) then X call smg$repaint_screen ( pasteboard ) X X elseif (term.eq.smg$k_trm_pf1) then X call smg$unpaste_virtual_display ( login_board, pasteboard ) X`09 call show_ports_menu (pasteboard, main, username,u_len) X call smg$repaint_screen ( pasteboard ) X`09 line = 3 X`09 col = 13 X call smg$set_cursor_abs ( main, line, col ) X bogus_key = .false. XC XC CtrlZ - exit to main display XC X elseif ((term.eq.smg$k_trm_ctrlz) .or. X`091 (term .eq. SMG$K_TRM_CR)) then X bogus_key = .false. X X endif X X enddo X X call smg$unpaste_virtual_display ( login_board, pasteboard ) X X end X X X Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc X X X`09subroutine CENTER_STRING (string, max_buffer_size, status) X Xc Xc`09This subroutine centers a text string for output. It assumes that Xc`09the input string is 80 characters long or less. The string is Xc`09centered as though it is to be put into an 80 byte buffer (since Xc`09most terminals can only handle 80 characters per line). It doesn't Xc`09hurt if the input string is longer than 80 bytes, however data will Xc`09be lost due to truncation. Xc X X`09CHARACTER*(*) string X`09CHARACTER*1 BLANK /' '/ X`09CHARACTER*100 TEMP, NULL_STRING X X`09INTEGER*4 BEGIN, L, I, J, K, status, max_buffer_size X X X`09status = 0 X X`09if (max_buffer_size .gt. 100) then X`09 status = .false. X`09 return X`09endif X XC XC---`09Clear out the TEMP string XC X`09call REPEAT (null_string , ' ') X`09TEMP = NULL_STRING X XC XC---`09Find location of first non-blank character in input string XC X`09DO I = 1, max_buffer_size X`09 IF (string(I:I) .NE. BLANK) GOTO 2 X`09END DO X XC XC---`09If here, then string contains all blanks ===> return XC X`09status = .false. X`09return X X X2`09LOC = I X XC XC---`09Remove leading blanks (i.e. left justify the string) unless LOC = 1 XC X X`09IF (LOC.EQ.1) GOTO 3 X X`09DO J = LOC-1, 1, -1 X X`09 DO K = J, max_buffer_size - 1 X`09 string (K:K) = string (K+1:K+1) X`09 END DO X X`09END DO X X3`09CONTINUE X XC XC---`09To determine how many meaningful characters string really XC---`09contains, start from rightmost side and search for first XC---`09non-blank character. This can be done since the above steps XC---`09have left-justified the string. XC X X`09DO I = max_buffer_size, 1, -1 X`09 IF (string (I:I) .NE. BLANK) GOTO 4 X`09END DO X X4`09CONTINUE X XC XC---`09Now know string has meaningful characters in locations 1:I XC X X`09BEGIN = INT ((float(max_buffer_size) - I) / 2.0) + 1 X X`09L = 1 X`09DO K = BEGIN, I + BEGIN - 1 X`09 TEMP (K:K) = string (L:L) X`09 L = L + 1 X`09END DO X XC XC---`09Set input string equal to nulls XC X X`09string = NULL_STRING XC XC---`09Now put centered string into input string XC X X`09string(1:max_buffer_size) = TEMP(1:) Xd`09write (66,*) string(1:max_buffer_size) XC XC---`09Possible upper case to be added here XC X X`09RETURN X`09END X Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc X X X`09subroutine SHOW_PORTS_MENU (pasteboard, main, uname, u_len) X X X X X`09include '($FORIOSDEF)' X`09include '($SSDEF)' X`09include '($LIBDEF)' X`09include '($SMGDEF)' X`09include 'dua2:`5Bkoffley.com`5Duserlog_struc.inc' X X`09common / SMG_data / paste_ID, kybd_ID, num_rows, num_cols, display_ID, X`091 mm_id X X`09integer*4 qheader (2), status, base_addr, LIB$GET_VM, ordinal, X`091 target_Length, paste_ID, kybd_ID, num_rows,`20 X`092 num_cols, display_ID, mm_id, bitmap_base_addr, X`093 pasteboard, cur_row, cur_col, main, mask X X`09logical found X X`09record / link_list / a X X`09data qheader / 2*0 / X X`09character*(*) uname X`09character*20 target_name X`09character*150 txt, blank X X`09character*20 servers (184) X`09common / server_info / servers, bitmap_base_addr X X`09integer*4 length, len_trim, ioerror, io_OK, rms_sts, rms_stv, X`091 option / 5 /, two / 2 /, one / 1 /,u_Len X X`09integer*4 zero, num_bytes, LIB$FREE_VM, bit_num X X`09data zero / 0 /, X`091 num_bytes / 24 / X X`09real*4 x, rands X`09integer*4 randi, lower / 1 /, upper / 181 / , X`091 start_seed / 1055744 / X X X`09x = rands (start_seed) X X`09paste_ID = pasteboard X X`09istat = LIB$GET_VM (num_bytes, bitmap_base_addr) X`09if (.not. istat) then X`09 call LIB$SIGNAL (%val(istat)) X`09endif X X`09call zero_page (%val(bitmap_base_addr)) X X`09call INIT_DISPLAYS X X X`09do while (option .gt. 0) X X`09 call SMG$PASTE_VIRTUAL_DISPLAY (mm_ID, paste_ID, 5, 20) X`09 call READ_MAIN_MENU_OPTION (option) X`09 call SMG$UNPASTE_VIRTUAL_DISPLAY (mm_id, paste_id) X X`09 if (option .eq. 4) then ! EXIT X`09 return X X`09 elseif (option .eq. 1) then ! Display full user records X`09 call SMG$PASTE_VIRTUAL_DISPLAY (display_ID, paste_ID, 8,2) X`09 target_name = uname(1:u_len) X`09 call OPEN_AND_READ (target_name, qheader, found) X`09 if (found) then X`09 call SHO_QUEUE (qheader) X`09 call SMG$UNPASTE_VIRTUAL_DISPLAY (display_ID, paste_ID) X`09 else Xc`09`09 output meaningful error message X`09 endif X X`09 elseif (option .eq. 2) then ! Display ports used only X`09 mask = SMG$M_BOLD + SMG$M_BLINK X`09 call SMG$PUT_CHARS (main, 'WORKING', 12, 35, ,mask) X`09 target_name = uname(1:u_len) X`09 call OPEN_AND_READ (target_name, qheader, found) X`09 if (found) then X`09 call SMG$ERASE_CHARS (main, 8, 12, 35) X`09 call DISPLAY_PORTS_ONLY (qheader) X`09 else Xc`09`09 output meaningful error message X`09 endif X X`09 elseif (option .eq. 3) then ! Display ports used only X`09 mask = SMG$M_BOLD + SMG$M_BLINK X`09 call SMG$PUT_CHARS (main, 'WORKING', 12, 35,, mask) X`09 target_name = uname(1:u_len) X`09 call OPEN_AND_READ (target_name, qheader, found) X`09 if (found) then X`09 call DISPLAY_PORTS_SUMMARY`20 X`09 call SMG$ERASE_CHARS (main, 8, 12, 35) X`09 else Xc`09`09 output meaningful error message X`09 endif X X`09 endif X X`09enddo X`09 X X1000`09end X X Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc X X X`09subroutine INSQH (qheader, username, server, time_stamp, mode, X`091 master_pid, pid, login_time, uic, terminal) X X X X X X`09integer*4 qheader (2), status, ordinal, num_bytes, X`091 new_addr, LIB$GET_VM X X`09include 'dua2:`5Bkoffley.com`5Duserlog_struc.inc' X`09record / link_list / qentry X X`09data num_bytes / 157 / X X X`09status = LIB$GET_VM (num_bytes, new_addr) X`09if (.not. status) call LIB$SIGNAL (%val(status)) X X`09if ((qheader(1) .ne. 0) .and. (qheader(2) .ne. 0)) then X`09 call UPDATE_FORWARD_LINK (%val(qheader(1)), new_addr) X`09 call UPDATE_BACK_LINK (%val(qheader(2)), new_addr) X`09 call FILL_NEW_ELEMENT (%val(new_addr), qheader(2), qheader(1),`20 X`091 username, server, time_stamp, mode, X`092 master_pid, pid, login_time, uic, terminal) X`09 qheader (1) = new_addr`20 X X`09else X`09 qheader (1) = new_addr X`09 qheader (2) = new_addr X`09 call FILL_NEW_ELEMENT (%val(new_addr), qheader(2), qheader(1),`20 X`091 username, server, time_stamp, mode, X`092 master_pid, pid, login_time, uic, terminal) X X`09endif X X X`09return X`09end X X Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc X X X X X`09subroutine INSQT (qheader, username, server, time_stamp, mode, X`091 master_pid, pid, login_time, uic, terminal) X X X X`09integer*4 qheader (2), status, ordinal, num_bytes, X`091 new_addr, LIB$GET_VM X X`09include 'dua2:`5Bkoffley.com`5Duserlog_struc.inc' X`09record / link_list / qentry X X`09data num_bytes / 157 / X X X`09status = LIB$GET_VM (num_bytes, new_addr) X`09if (.not. status) call LIB$SIGNAL (%val(status)) X X`09if ((qheader(1) .ne. 0) .and. (qheader(2) .ne. 0)) then X`09 call UPDATE_FORWARD_LINK (%val(qheader(1)), new_addr) X`09 call UPDATE_BACK_LINK (%val(qheader(2)), new_addr) X`09 call FILL_NEW_ELEMENT (%val(new_addr), qheader(2), qheader(1),`20 X`091 username, server, time_stamp, mode, X`092 master_pid, pid, login_time, uic, terminal) X`09 qheader (2) = new_addr`20 X X`09else X`09 qheader (1) = new_addr X`09 qheader (2) = new_addr X`09 call FILL_NEW_ELEMENT (%val(new_addr), qheader(2), qheader(1),`20 X`091 username, server, time_stamp, mode, X`092 master_pid, pid, login_time, uic, terminal) X X`09endif X X X`09return X`09end X X Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc X X X X`09subroutine UPDATE_FORWARD_LINK (qentry, new_addr) X X X`09include 'dua2:`5Bkoffley.com`5Duserlog_struc.inc' X X`09record / link_list / qentry X X X`09integer*4 new_addr X X X X`09qentry.forward_link = new_addr X X X X X`09return X`09end X X Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc X X X X X`09subroutine UPDATE_BACK_LINK (qentry, new_addr) X X X`09include 'dua2:`5Bkoffley.com`5Duserlog_struc.inc' X X`09record / link_list / qentry X X X`09integer*4 new_addr X X X X`09qentry.back_link = new_addr X X X X X`09return X`09end X X Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc X X X`09subroutine FILL_NEW_ELEMENT (qentry, fl, bl, username, server, X`091 time_stamp, mode, master_pid, pid, X`092 login_time, uic, terminal) X X X`09include 'dua2:`5Bkoffley.com`5Duserlog_struc.inc' X X`09record / link_list / qentry X X`09integer*4 fl, bl, ord X X X X`09qentry.forward_link = fl X`09qentry.back_link = bl X`09qentry.username = username X`09qentry.server = server X`09qentry.time_stamp = time_stamp X`09qentry.mode = mode X`09qentry.master_PID = master_pid X`09qentry.pid = pid X`09qentry.login_time = login_time X`09qentry.uic = uic X`09qentry.terminal = terminal X X`09return X`09end X Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc +-+-+-+-+-+-+-+- END OF PART 13 +-+-+-+-+-+-+-+- -- \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/ < Joe Koffley KOFFLEY@NRLVAX.NRL.NAVY.MIL > < Naval Research Laboratory KOFFLEY@CCF.NRL.NAVY.MIL > < Space Systems Division AT&T : 202-767-0894 > \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/