FTN4,L
C 
C  ***************************************************************
C  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  ALL RIGHTS     *
C  * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,      *
C  * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT*
C  * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.       *
C  ***************************************************************
C 
C     SOURCE PART NUMBER :92067-18374 
C 
C     RELOCATABLE PART NUMBER : 92067-16362 
C 
C     PROGRAMER(S)   : J.M.N. 
C 
C 
C 
C     ACPAS - ROUTINE TO VERIFY ACCESS TO ACCTS PROGRAM 
C 
C     CALLING SEQUENCE:  CALL ACPAS 
C 
C     ACERRS:            -204 = INVALID PASSWORD
C 
C 
      SUBROUTINE ACPAS  ,92067-16362 REV.1940 790801
      DIMENSION MSPAS(5),IUSER(5),IGRP(5),LUX(2),IESC(2)
      COMMON /ACOM1/NDCB(272),NBUF(128) 
      COMMON /ACOM3/LIST(10),LDCB(144),LLIST,LLDCB(144),ITTY,ITDCB(144) 
      COMMON /ACOM6/LOC(6)
      COMMON /ACOM7/IPBUF(11) 
      COMMON /ACOM9/IBUF(40)
      COMMON /ACOMC/IECHO,LULOG,ITLOG,KECHO 
      COMMON /ACOMD/ICLASS,KPB,KRR,KRRR,IDSES,MYCAP,MYDIR,MYGID 
      DATA MSPAS/2HPA,2HSS,2HWO,2HRD,2H? /
C 
C     CHECK IF PASSWORD EXISTS FOR ACCOUNT
C     WITH USER ID 7777B  (MANAGER.SYS) 
C 
      I1=LOC(5) 
      I2=LOC(6)-1 
      DO 50 I=I1,I2 
      CALL READF(NDCB,IERR,NBUF,128,LEN,I)
      DO 50 J=1,128,16
      IF(NBUF(J).LT.0) GO TO 50 
      IF(NBUF(J+11).EQ.7777B) GO TO 60
   50 CONTINUE
      GO TO 400 
C 
C     READ THE ACCOUNT
C 
   60 IREC=NBUF(J+14) 
      IOFST=0 
      IF(0.GT.IREC) IOFST=64
      IREC=IAND(IREC,77777B)
      CALL READF(NDCB,IERR,NBUF,128,LEN,IREC) 
      I=IAND(NBUF(IOFST+1),255) 
      IF(I.EQ.0) GO TO 400
C 
C     PROMPT WITH "PASSWORD? "
C     AND FETCH IT
C 
      KECHO=0 
      CALL ACPSN(MSPAS,5,IPBUF,IERR)
      KECHO=400B
C 
C     COMPARE PASSWORD WITH MANAGER.SYS ACCOUNT 
C 
  200 DO 300 I=2,6
      IF(IPBUF(I).NE.NBUF(IOFST+I)) GO TO 500 
  300 CONTINUE
  400 IDSES=7777B 
      RETURN
  500 CALL ACERR(-204)
      CALL ACTRM
      END 
C     ACAPA ALTERS THE CURRENT USERS PASSWORD 
C 
      SUBROUTINE ACAPA ,92067-16362 REV.2013 800131 
      DIMENSION IWIPE(24),LU(2),KWIPE(23) 
      COMMON /ACOM1/NDCB(272),NBUF(128) 
      COMMON /ACOM3/LIST(10),LDCB(144),LLIST,LLDCB(144),ITTY,ITDCB(144) 
      COMMON /ACOM6 /LOC(6),IRN 
      COMMON /ACOM7/IPBUF(11),ISTRC,JPBUF(11) 
      COMMON /ACOM9/IBUF(40),JBUF(96) 
      COMMON /ACOMC/IECHO,LULOG,ITLOG,KECHO 
      COMMON /ACOMD/ICLASS,KPB,KRR,KRRR,IDSES,MYCAP,MYDIR,MYGID 
      EQUIVALENCE (IWIPE(2),KWIPE(1)) 
C 
      DATA IWIPE / 15501B,6415B,5*2HXX,6527B,4*2HWW,53415B,5*2HII 
     1,6460B,4*2H00,2H0   / 
C 
C     GO ASK FOR CURRENT  PASSWORD
C 
      KECHO=0 
      CALL ACPSN(26HENTER CURRENT PASSWORD   _,13,JBUF,IERR)
      KECHO=400B
      CALL ACWRI(2H  ,1)
C 
C     GET CURRENT PASSWORD
C 
      CALL ACDIR(1,MYDIR,IBUF,IERR) 
      IOF=0 
      IREC=IBUF(15) 
      IF(0.GT.IREC) IOF=64
      IREC=IAND(IREC,77777B)
      CALL READF(NDCB,IERR,NBUF,128,LEN,IREC) 
C 
C     VERFY PASSWORD
C 
      DO 100 I=1,6
      IF(NBUF(I+IOF).NE.JBUF(I)) GO TO 900
  100 CONTINUE
C 
C     ASK FOR  NEW PASSWORD 
C 
      KECHO=0 
      CALL ACPSN(26HENTER   NEW   PASSWORD   _,13,JBUF,IERR)
      KECHO=400B
      IF(IERR.NE.0) RETURN
      CALL ACPRM(22HTHE NEW PASSWORD IS:  ,11)
      CALL ACPRM(2H  ,1)
      JBUF(7)=2H
      JBUF(8)=2HOK
      JBUF(9)=2H (
      JBUF(10)=2HY
      JBUF(11)=2H0R 
      JBUF(12)=2H N 
      JBUF(13)=2H)? 
      JBUF(14)=2H _ 
      CALL ACPRM(JBUF(2),13)
      IF(ITTY.LE.0.OR.ITTY.GT.255) GO TO 150
      LU(1)=IOR(100000B,ITTY) 
      LU(2)=2100B 
      CALL XLUEX(1,LU,IPB,-1) 
      CALL ACPRM(IWIPE,24)
      CALL ACPRM(KWIPE,23)
      IF(IPB.NE.131B) RETURN
      CALL ACPRM(22HNEW PASSWORD INSTALLED    ,11)
C 
C     INSTALL THE NEW PASSWORD
C 
  150 CALL RNRQ(1,IRN,ISTAT)
      CALL READF(NDCB,IERR,NBUF,128,LEN,IREC) 
      DO 200 I=1,6
      NBUF(I+IOF)=JBUF(I) 
  200 CONTINUE
      CALL WRITF(NDCB,IERR,NBUF,128,IREC) 
      CALL RNRQ(4,IRN,ISTAT)
      RETURN
  900 CALL ACERR(-204)
      CALL ACTRM
      END 
C 
C 
C 
C 
C 
C     ACPSN PARSES A PASSWOORD
C 
C     CALLING SEQUENCE
C 
C         CALL ACPSN(MESS,LENGTH,JPASS,IERR)
C  C
C  C           WHERE MESS    IS PROMPT
C  C                 LENGTH  IS LENGTH OF PROMPT IN WORDS 
C  C                 JPASS   IS THE BUFFER FOR PARSED PASSWORD
C  C                 IERR    IS ERROR CODE
C 
C 
      SUBROUTINE ACPSN(MESS,MESSL,JPASS,IERR) 
     1 ,92067-16362 REV.1940 790801 
      COMMON /ACOM1/NDCB(272),NBUF(128) 
      COMMON /ACOM3/LIST(10),LDCB(144),LLIST,LLDCB(144),ITTY,ITDCB(144) 
      COMMON /ACOM6 /LOC(6),IRN 
      COMMON /ACOM7/IPBUF(11),ISTRC,JPBUF(11) 
      COMMON /ACOM9/IBUF(40),JBUF(96) 
      COMMON /ACOMC/IECHO,LULOG,ITLOG,KECHO 
      COMMON /ACOMD/ICLASS,KPB,KRR,KRRR,IDSES,MYCAP,MYDIR,MYGID 
      DIMENSION JPASS(6),LUX(2),IESC(2) 
      DATA LUX,IESC /0,0,15501B,15515B /
C 
C     PROMPT FOR USER PASSWORD
C 
 1100 CALL ACPRM(MESS,MESSL)
      CALL ACREI(IBUF,IERR) 
      IF(KECHO.EQ.400B) GO TO 1105
C 
C     TEST FOR DVR07
C 
      IF(ITTY.LE.0.OR.ITTY.GT.255) GO TO 1105 
      LUX(1)=IOR(100000B,ITTY)
      CALL XLUEX(13,LUX,IEQT5)
      IEQT5=IAND(37400B,IEQT5)/256
      IF(IEQT5.NE.7B) GO TO 1105
      CALL XLUEX(2,LUX,IESC,2)
 1105 ICHAR=1 
      CALL PARSN(JPBUF,IBUF,80,ICHAR,IERR)
      IF(IERR.EQ.0) GO TO 1120
C 
C     CHECK FOR REQUEST TO ABORT COMMAND
C 
      IF(JPBUF(2).EQ.2H/A.OR.JPBUF(2).EQ.2H/E) RETURN 
 1110 CALL ACERR(-204)
      IF(KECHO.EQ.0) CALL ACTRM 
      IERR=0
      GO TO 1100
C 
C     IF NO PASSWORD SPECIFIED, DEFAULT TO NONE 
C 
 1120 IF(JPBUF(1).NE.0) GO TO 1140
      DO 1130 KNDX=2,6
      JPASS(KNDX)=2H
 1130 CONTINUE
      GO TO 1170
C 
C     PASSWORD CAN'T BE IN USER.GROUP FORMAT
C 
 1140 IF(IAND(JPBUF(1),255).NE.0) GO TO 1110
      DO 1150 KNDX=2,6
      JPASS(KNDX)=JPBUF(KNDX) 
 1150 CONTINUE
 1170 JPASS(1)=JPBUF(1)/256 
      RETURN
      END 
                                                                                                                                                                        