      program swap
c
c       Author: Chris Chaundy
c       Date:   02-Jun-1981
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 home-in
c on a predefined account.
c
c	Modified: J.James Belonis II added ACL to LNM$JOB table
c		  to allow SWAP then SPAWN to work under VMS 4.4
c       Modified: 02-May-1985  Gregory C. Lowney added new-mail notification
c                 for VMS V4.
c       Modified: 24-Mar-1985, Gordon Davisson rewrote uafdef.dck for VMS V4
c                 and removed mail notification.
c       Modified: Gordon Davisson added SYS$LOGIN, SYS$SCRATCH, mail notice and
c                 ME$PROC logical name to append USERNAME to for process name.
c
      implicit none

      parameter reqd_priv = '10000001'x, home = 'MANAGER'

      include 'uafdef.dck'
      include '($ssdef)'
      include '($libdef)'
      include '($acldef)'

      character prcnam*15, buffer*60, mailmess*40
      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

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

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

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 ) goto 10

c Default username if no command line
      if ( length .eq. 0 ) uaf$t_username = home

! set usernamelen
      usernamelen = nblen( uaf$t_username )

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 10
      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 string descriptor
      usrdsc( 2 ) = %loc( uaf$t_username )

      accdsc( 1 ) = len( uaf$t_account )        ! account string 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
         call sys$fao( '     !AS has !SL new mail message!%S.',
     $              maillen ,mailmess,
     $              uaf$t_username(:usernamelen), %val(mailcount) )
         type *, mailmess(:maillen)
      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 *, 'Username not found in UAF'
      call exit

   30 type *, 'Insufficient privilege to run SWAP'
      call exit

      end
