      program swap_pair
c
c       Author: Chris Chaundy
c       Date:   02-Jun-1981
c
c	10/1/86    J.James Belonis II added ACL to LNM$JOB table
c		  to allow SWAP then SPAWN to work under VMS 4.4
c       4/22/85 -- Gregory C. Lowney
c             Modified to print correct new mail message under VMS 4.0.
c             Added new function New_Mail_Count().
c             Corrected exit with error if sys$setprv fails.
c             Added logical name ME$USER
c       31-MAR-1985 J.J.Belonis used Gordon Davisson's rewritten SWAP
c               to convert for VMS 4.0
c       30-SEP-1984 J.J.Belonis changed error messages, added usernames
c       Modified: September 1984, Simon Radford; checks
c               if swap is allowed.
c       Modified: Gordon Davisson adding SYS$LOGIN, SYS$SCRATCH, mail notice
c                 and ME$PROC logical name to append USERNAME for process name
c
c This program reads a UAF record (specified by username) and
c sets up the current process to look like that user.  It sets
c the username, UIC, privileges, etc... to that of the specified
c username.  If no username is given, the program will prompt
c for a destination username
c
      implicit integer*4 (a-z)

      parameter reqd_priv = '10000001'x

      include 'dra0:[sys0.sysmgr.spy.swap]uafdef.dck'
      include '($ssdef)'
      include '($libdef)'
      include '($acldef)'

        Character mailmess*40
        Character current_username*12

        Integer*2 jpi_itmlst2(2)        !arg block for getjpi
        Integer*4 jpi_itmlst(4)
        Equivalence (jpi_itmlst,jpi_itmlst2)

      character prcnam*15, buffer*60
      integer*4 argblk(4), usrdsc(2), accdsc(2), minprv(2),
     -  prvmsk(2), nopriv(2), stat, usernamelen, length, lenshort
     -  lib$get_foreign, sys$setprv, lib$set_logical, sys$cmkrnl,
     -  nblen, sys$trnlog, sys$setprn, sys$setddir, new_mail_count,
     -  mailcount, maillen, errpos

        parameter n_usernames = 68
        Character*12 Username_xref(2,n_usernames) !(1,i) is start, (2,i) is des
        Data Username_Xref /            ! to add users, add username pairs
     1  'RADFORD','SIMON',      ! and update the n_usernames parameter
     1  'SIMON','RADFORD',
     2	'ALLYN','WEAKS',
     2  'GHOSE','WEAKS',
     2  'SHAIKH','WEAKS',
     2  'WEAKS','ALLYN',
     2  'WEAKS','GHOSE',
     2  'WEAKS','SHAIKH',
     3  'AIPSBM','MARGON',
     3  'JOAN','MARGON',
     3  'MARGON','AIPSBM',
     3  'MARGON','JOAN',
     4  'GABRIELSE','GERALD',
     4  'GERALD','GABRIELSE',
     6  'WILKES','VILETT',
     6  'WILKES','IWAI',
     6  'WILKES','SCANRS',
     7  'BICK','MARTIN',
     7  'BICK','MBICK',
     7  'MARTIN','BICK',
     7  'MBICK','BICK',
     8  'EXAFS','OLIVER',
     8  'OLIVER','EXAFS',
     9  'DRIC','PUFF',
     9  'PUFF','DRIC',
     1  'DGB','DGBD',
     1  'DGB','DGBPRL',
     1  'DGB','VAXCHAIR',
     1  'DGBD','DGB',
     1  'DGBD','DGBPRL',
     1  'DGBD','VAXCHAIR',
     1  'DGBPRL','DGB',
     1  'DGBPRL','DGBD',
     1  'DGBPRL','VAXCHAIR',
     1  'VAXCHAIR','DGB',
     1  'VAXCHAIR','DGBD',
     1  'VAXCHAIR','DGBPRL',
     2  'AIPSMM','NABUC',
     2  'NABUC','AIPSMM',
     3  'AIPSPH','HODGE',
     3  'HODGE','AIPSPH',
     4  'JENNER','ASTRONOMY',	! note SANDI too.
     4  'ASTRONOMY','JENNER',
     4  'JENNER','DAVEJ',	
     4  'DAVEJ','JENNER',
     4  'JENNER','UVCP',
     4  'UVCP','JENNER',
     4  'JENNER','DJENNER',
     4  'DJENNER','JENNER',
     5  'AIPSWS','WOODY',
     5  'WOODY','AIPSWS',
     6  'RSVDEPT','VANDYCK',
     6  'SEPARIS','VANDYCK',
     6  'VANDYCK','RSVDEPT',
     6  'VANDYCK','SEPARIS',
     7  'SPIES','SPIESMAN',
     7  'SPIESMAN','SPIES',
     8  'AIPSHP','PRESTON',
     9  'PRESTON','AIPSHP',
     1  'LW','WILETS',
     1  'WILETS','LW',
     2  'GREC','LOWNEY',
     2  'LOWNEY','GREC',
     3  'ASTRONOMY','SANDI',	! note JENNER too
     3  'SANDI','ASTRONOMY',
     4  'GREC','GORDON',
     4  'GORDON','GREC',
     5  'OWEN','AIPSRO'
     -                  /


c  Functions
      integer*4 sys$parse_acl, sys$change_acl
c      integer*4 sys$format_acl

c  Define item list structure
       STRUCTURE	/ITMLST/
          UNION
             MAP
                INTEGER*2	BUFLEN, ITMCOD
                INTEGER*4 BUFADR, UNUSED
             END MAP
             MAP
                INTEGER*4	END_LIST
             END MAP
          END UNION
       END STRUCTURE


C      Declare SYS$MODIFY_ACL item list
       RECORD /ITMLST/	JOB_ACL_ITEM(2)

c  Define item list structure
       STRUCTURE	/STRING/
          UNION
             MAP
                INTEGER*2 STRINGLEN, STRINGTYPE
                INTEGER*4 BUFADR
             END MAP
          END UNION
       END STRUCTURE

C      Declare ACLENT string  so can get at buffer directly
       RECORD /STRING/	ACLENTSTRING
	BYTE STRINGBUF(ACL$S_ADDACLENT)
c	character*50 aclstr

      external swapuser
        external jpi$_username

      data minprv / reqd_priv, 0 /, nopriv / 2*-1 /

        Data jpi_itmlst2(1) /12/
        data jpi_itmlst(4) /0/
        Jpi_itmlst2(2) = %loc(jpi$_username)
        jpi_itmlst(2) = %loc(current_username)
        jpi_itmlst(3) = %loc(current_username_len)

C  Init string
	ACLENTSTRING.STRINGLEN = ACL$S_ADDACLENT
	ACLENTSTRING.BUFADR = %LOC(STRINGBUF)

c Get user command line
      stat = lib$get_foreign( uaf$t_username,, length )
      if ( stat .ne. ss$_normal .and.
     -     stat .ne. lib$inpstrtru ) goto 10

c Prompt for username if no command line
      if ( length .eq. 0 ) then
           stat = lib$get_input (uaf$t_username,'$_Username: ',length)
           if (stat .eq. %loc(rms$_eof)) call exit
           if (stat .ne. ss$_normal) goto 10
           end if

c Translate destination to uppercase
        stat = str$upcase (uaf$t_username,uaf$t_username)
        If (stat .ne. ss$_normal) goto 10
        write (uaf$t_username,'(a12)') uaf$t_username   ! truncate ?

! set usernamelen
      usernamelen = nblen( uaf$t_username )

c Get current username
        pid = 0                 !current process
        stat = sys$getjpi (%val(1), pid,, %ref(jpi_itmlst),,,)
        if (stat .ne. ss$_normal) goto 10

c Check if desired swap is allowed
        do i_user = 1,n_usernames
           if (current_username .eq. username_xref (1,i_user)
     1       .and. uaf$t_username  .eq. username_xref (2,i_user) )
     2       goto 1
           end do
        goto 40                 !illegal swap exit
1       continue
d       type *,'trying swap'

c Try to get minimum necessary priv's for us to work
      stat = sys$setprv( %val( 1 ), minprv,, )
      if ( stat .ne. ss$_normal ) go to 30
      stat = sys$setprv( ,,, prvmsk )
      if ( stat .ne. ss$_normal ) go to 10
      if (( prvmsk( 1 ) .and. minprv( 1 )) .ne. minprv( 1 )) goto 30

c Open the UAF and get the vital information
      open( unit=1, file='sys$system:sysuaf.dat', readonly, shared,
     -  access='keyed', organization='indexed', status='old' )
      read( 1, key=uaf$t_username, keyid=0, err=20 ) uaf$_record
      close( 1 )

c Set an ACL allowing destination user to write in Job Logical Name Table
c  write translation of acl into item list via structures
      stat = sys$parse_acl( 
     -   '(id='//uaf$t_username(1:usernamelen)//',access=read+write)',
     -                    aclentstring, errpos, )
      if( .not.stat ) then
          print *,'%SWAP-F-BADACL Bad ACL at character position ',errpos
          goto 10
      endif

cc  Verify VMS understands what I said
c      stat = sys$format_acl( aclentstring,, aclstr,,,,)
c      if(.not.stat) then
c          print *,'%SWAP-F-BADACLENT Bad ACLENT format'
c          goto 10
c      endif
c	print *,aclstr

C  Initialize item list for the SYS$CHANGE_ACL 
       JOB_ACL_ITEM(1).BUFLEN = STRINGBUF(1)
       JOB_ACL_ITEM(1).ITMCOD = ACL$C_ADDACLENT
       JOB_ACL_ITEM(1).BUFADR = %LOC(STRINGBUF)
       JOB_ACL_ITEM(1).UNUSED = 0		! no length to return
       JOB_ACL_ITEM(2).END_LIST = 0

      stat = sys$change_acl( ,%ref(acl$c_logical_name_table),
     -  'LNM$JOB', job_acl_item,,, )
      if( .not.stat ) goto 10

c Set up appropriate default device and directory
      if ( uaf$c_defdev .eq. 0 ) then
         uaf$t_defdev = 'SYS$SYSDISK:'
         uaf$c_defdev = 12
      end if
      stat = lib$set_logical(
     -  'SYS$DISK', uaf$t_defdev( : uaf$c_defdev ))
      if ( .not. stat ) goto 10
      stat = sys$setddir( uaf$t_defdir( : uaf$c_defdir ),, )
      if ( .not. stat ) goto 10

c Set up SYS$LOGIN: and SYS$SCRATCH:
      stat = lib$set_logical( 'SYS$LOGIN',
     -  uaf$t_defdev( : uaf$c_defdev ) //
     -  uaf$t_defdir( : uaf$c_defdir ))
      if ( .not. stat ) goto 10

      stat = lib$set_logical( 'SYS$SCRATCH',
     -  uaf$t_defdev( : uaf$c_defdev ) //
     -  uaf$t_defdir( : uaf$c_defdir ))
      if ( .not. stat ) goto 10

c Set up SWAPUSER argument block and call it in kernel mode
      usrdsc( 1 ) = len( uaf$t_username )       ! username descriptor
      usrdsc( 2 ) = %loc( uaf$t_username )

      accdsc( 1 ) = len( uaf$t_account )        ! account descriptor
      accdsc( 2 ) = %loc( uaf$t_account )

      argblk( 1 ) = 3                           ! argument block
      argblk( 2 ) = %loc( usrdsc )
      argblk( 3 ) = %loc( uaf$l_uic )
      argblk( 4 ) = %loc( accdsc )

      stat = sys$cmkrnl( swapuser, argblk )
      if ( .not. stat ) goto 10

! get newmail count while still privileged
! because mail info kept in a protected file under vms 4.0.
! don't print message until after privs removed.

      mailcount = new_mail_count()

c Clear process privilege mask and then set appropriately
      stat = sys$setprv( , nopriv, %val( 1 ), )
      if ( .not. stat ) goto 10
      stat = sys$setprv( %val( 1 ), uaf$q_priv, %val( 1 ), )
      if ( .not. stat ) goto 10

! print new mail count message.

      if( mailcount.lt.0 ) then
         type *,
     $     '%SWAPPAIR-W-ACCMAIL, unable to access VMS Mail data.'
      else if( mailcount.gt.0 ) then
         userlen = nblen( uaf$t_username )
         call sys$fao( '     !AS has !SL new mail message!%S.',
     $              maillen ,mailmess,
     $              uaf$t_username(:userlen), %val(mailcount) )
         type *, mailmess(:maillen)
      end if

! define logical name ME$USER if it doesn't already exist.
! it should be the original login-username.
! we use the character string Prcnam as a scratch buffer.
      stat = lib$sys_trnlog( 'ME$USER',, prcnam )
      if( stat.eq.ss$_notran ) then
         current_username_len = nblen( current_username )
         stat = lib$set_logical( 'ME$USER',
     $               current_username(:current_username_len) )
         if( .not.stat ) type *,
     $    '%SWAPPAIR-W-BADLOG, cannot create logical name ''ME$USER'''
      else if( .not.stat ) then
         type *,
     $   '%SWAPPAIR-W-BADTRN, cannot translate logical name ''ME$USER'''
      end if

c To complete things, try to change our process name
      stat = sys$trnlog( 'ME$PROC', length, prcnam,,, )
      if ( stat .eq. ss$_notran ) length = 0
      if ( usernamelen+length.gt.15 ) then
         lenshort = 15-usernamelen
         prcnam( lenshort : lenshort )=prcnam( length:length )
         length=lenshort
      endif
      prcnam( length+1 : ) = uaf$t_username     ! appends username to ME$PROC
      length = max( length, nblen( prcnam ))
      stat = sys$setprn( prcnam( :length ))
      if ( stat .eq. ss$_duplnam ) then
         stat = sys$trnlog( 'TT', length, prcnam,,, )
         if ( stat ) then
            if ( prcnam( :2 ) .eq. '__' ) then
               prcnam = prcnam( 2: )
               length = length - 1
            end if
            stat = sys$setprn( prcnam( 2 : length ))
         end if
         if ( .not. stat ) stat = sys$setprn()
      end if

c Normal and error exits
   10 call exit( stat )

   20 type *, '%SWAPPAIR-F-USRNOTFND Username not found in UAF'
      call exit

   30 type *, '%SWAPPAIR-F-INSPRV Insufficient privilege'
      call exit

40      type *, '%SWAPPAIR-F-ILLDESREQ Illegal destination requested'
        call exit

      end
