program news ******************************************************************************** * * N E W S * * This is the VAXV news system. Give us 800 blocks, we'll give you the world! * ******************************************************************************** logical full, cli$present integer printtoend, set_usermax integer*2 usermax, textmax, start character*10 param1 external msg_badnum, msg_illegal * See if they are requesting a full listing and set the flag accordingly * Then get the number of the highest unseen news item and the maximum * news item. full = cli$present('full') .and. (.not. cli$present('brief')) call get_maxes(usermax,textmax) * Check through the possible qualifiers and act accordingly. if (cli$present('all')) then call printrange(1,textmax,full) if (full) call set_usermax(textmax) else if (cli$present('itemnum')) then call cli$get_value('itemnum',param1) read (param1,10,err=1000) start if (start .ge. 1 .and. start .le. textmax) then call printrange(start,start,.true.) else call lib$signal(msg_badnum) end if else if ((.not. cli$present('login')).and.usermax.gt.textmax) then write (*,20) else if (cli$present('login') .and. usermax .le. textmax) * write (*,30) call printrange(usermax,textmax,full) if (full) call set_usermax(textmax) end if call exit * Error branch. Clean up and go home. 1000 call lib$stop(msg_illegal) 10 format (i) 20 format ('0There is no new news. For a list of available news' * ,' items, enter: ',//,' $ NEWS/ALL/BRIEF',// * ,' For more information on NEWS, enter:',// * ,' $ HELP NEWS',/) 30 format (' To obtain more information on the following news items',/ * ,' and REMOVE this login message, enter: $ NEWS',// * ,' Current unread news items are:',/) end subroutine get_maxes(usermax,textmax) ******************************************************************************** * * This routine returns the number of the last news item seen by the current * user and the maximum news item number contained in the text file from the * NEWSUSERS file. If the user has not read any news, a 'userame' record * will not be present in the NEWSUSERS file. In this case, zero is returned. * ******************************************************************************** parameter NEWSUSERS='NEWS$DIR:NEWSUSERS' parameter JPI$_USERNAME='202'X, PRV$M_SYSPRV='10000000'X parameter RESOURCE='RIT_NEWSUSERS_LCK' include 'lckdef.inc' integer length, length_adr, user_adr, end/0/ integer lksb(2), lksb1(2) integer*2 itemcode, bufferlen, usermax, textmax character*12 username, textmax_key/'DEFAULT'/ external msg_panic common /descr/ bufferlen, itemcode, user_adr, length_adr, end * Before getting the user information, start up the enqueue request for * the user file. We are looking for the username of the invoking process. call sys$enq(,%val(LCK$K_CRMODE),LKSB,%val(LCK$M_SYSTEM),RESOURCE, * ,,,,,) bufferlen = 12 itemcode = JPI$_USERNAME user_adr = %loc(username) length_adr = %loc(length) call sys$getjpi(,,,bufferlen,,,) * If the first enqueue request has not completed, wait for it now. * Then, we must enqueue on the specific record of the NEWSUSERS file that * is associated with the particular process. call sys$waitfr(%val(0)) call sys$enqw(,%val(LCK$K_PRMODE),LKSB1,%val(LCK$M_SYSTEM), * username,%val(lksb(2)),,,,,) * Since we're through the enqueues, we can open the file. We need to get * back our SYSPRV to open the file since it is protected. After the file is * opened, give back the privilege. call sys$setprv(%val(1),PRV$M_SYSPRV,,) open (unit=101, file=NEWSUSERS, status='old', form='formatted', * access='keyed', key=(1:12:character), recordtype='variable', * carriagecontrol='none', organization='indexed', shared, readonly, * err=10000) call sys$setprv(%val(0),PRV$M_SYSPRV,,) * Read in the users record. Branch to 20 if there is no such record. * (which implies a new user). This will return 1. usermax = 0 read (101,10,err=20,key=username) username, usermax 10 format (a12,i4) 20 usermax = usermax + 1 * Read in the 'TEXTMAX_KEY' record to determine the maximum news item entry read (101,10,key=textmax_key) textmax_key, textmax * Clean up by closing the files and dequeueing. close (unit=101) call sys$deq(%val(lksb1(2)),,,) call sys$deq(%val(lksb(2)),,,) return 10000 call lib$stop(msg_panic) end subroutine set_usermax(lastitem) ******************************************************************************** * * This routine updates the NEWSUSERS file to contain the new 'highest number * read' for the current user. * ******************************************************************************** parameter NEWSUSERS='NEWS$DIR:NEWSUSERS' parameter NEWSUNIT=101 parameter JPI$_USERNAME='202'X, PRV$M_SYSPRV='10000000'X parameter RESOURCE='RIT_NEWSUSERS_LCK' include 'lckdef.inc' integer length, length_adr, user_adr, end/0/ integer lksb(2), lksb1(2) integer*2 lastitem, itemcode, bufferlen character*12 username external msg_panic common /descr/ bufferlen, itemcode, user_adr, length_adr, end * We need to enqueue on the user file for access to the user record. * Start out the enqueue on the whole file while obtaining info about the * user. call sys$enq(,%val(LCK$K_CRMODE),LKSB,%val(LCK$M_SYSTEM),RESOURCE, * ,,,,,) bufferlen = 12 itemcode = JPI$_USERNAME user_adr = %loc(username) length_adr = %loc(length) call sys$getjpi(,,,bufferlen,,,) * We've got the info we need. Wait for the enqueue request to complete * if we don't have it yet! Then lock the specific record for writing. call sys$waitfr(%val(0)) call sys$enqw(,%val(LCK$K_PWMODE),LKSB1,%val(LCK$M_SYSTEM), * username,%val(lksb(2)),,,,,) * Get back the SYSPRV and open the users file. After it's open, give up * the privilege again. call sys$setprv(%val(1),PRV$M_SYSPRV,,) open (unit=NEWSUNIT, file=NEWSUSERS, status='old', form='formatted', * access='keyed', key=(1:12:character), recordtype='variable', * carriagecontrol='none', recl=20, organization='indexed', shared, * err=10000) call sys$setprv(%val(0),PRV$M_SYSPRV,,) * Write or rewrite the record (whichever is necessary!) read (NEWSUNIT,10,err=20,key=username) username rewrite (NEWSUNIT,10) username, lastitem 10 format (a12,i4) goto 30 20 write (NEWSUNIT,10) username, lastitem goto 30 * Clean up by closing the file and dequeueing. 30 close (unit=NEWSUNIT) call sys$deq(%val(lksb1(2)),,,) call sys$deq(%val(lksb(2)),,,) return 10000 call lib$stop(msg_panic) end logical function printitem(number,full) ******************************************************************************** * * This function prints a single item on SYS$OUTPUT. The amount of information * printed is based on the 'full' flag. If full is specified, the entire * news item is displayed. If not, only the first line of the item is * displayed. There are a maximum of 9998 news items allowed! The news file * is assumed already open. * * This function returns TRUE if it completes without error. * ******************************************************************************** logical full integer*2 number, tmp_number character*72 text * Use keyed access to obtain the first record of the news item. read (100,err=100,key=number) tmp_number, text * If 'full' is requested, display the entire news item. If not, * only the first line. if (full) then write (*,30) number do while (tmp_number .eq. number) write (*,20) text(1:lenc(text)) read (100) tmp_number, text end do else write (*,40) number,text(1:lenc(text)) end if * Return TRUE if we make it through the whole item without error. printitem = .true. return * Return FALSE if something went wrong. 100 printitem = .false. return 10 format (i2,a72) 20 format (1x,a) 30 format (/,' *** News item ',i3,' ***',/) 40 format (1x,i3,'. ',a) end subroutine printrange(start,end,full) ******************************************************************************** * * This routine displays a range of news items using repeated calls to * printitem. If a full listing is requested, the user must enter a * after each item to continue to the next. * ******************************************************************************** character*120 chardummy logical full, printitem integer lksb(2) integer*2 start, end, count external msg_panic parameter NEWSTEXT='NEWS$DIR:NEWSTEXT' parameter NEWSUNIT=100 parameter PRV$M_SYSPRV='10000000'X parameter RESOURCE = 'RIT_NEWSTEXT_LCK' include 'lckdef.inc' * We have to request an enqueue to be allowed access to the NEWSTEXT file. call sys$enqw(,%val(LCK$K_PRMODE),LKSB,%val(LCK$M_SYSTEM), * RESOURCE,,,,,,) * The enqueue let us past, so we need to get SYSPRV and open the file call sys$setprv(%val(1),PRV$M_SYSPRV,,) open (unit=NEWSUNIT, file=NEWSTEXT, status='old', * form='unformatted', access='keyed', recordtype='variable', * carriagecontrol='none', organization='indexed', * shared, readonly, err=10000) * We don't need SYSPRV anymore, so give it up! (avoids potential problems) call sys$setprv(%val(0),PRV$M_SYSPRV,,) do count = start,end if (printitem(count,full) .and. count .lt. end .and. full) then print *,' ' call lib$get_input(chardummy,'Hit return to continue: ',) call lib$erase_page(1,1) end if end do * Close the news text file, dequeue the resource and go home. close (unit=NEWSUNIT) call sys$deq(%val(lksb(2)),,,) return 10000 call lib$stop(msg_panic) end integer function lenc(string) ******************************************************************************** * * This routine returns the REAL (not FORTRAN REAL either!) length of a * character string, not including trailing blanks. * ******************************************************************************** character*(*) string lenc = len(string) do while (string(lenc:lenc) .eq. ' ' .and. lenc .gt. 1) lenc = lenc - 1 end do return end