From:	CSBVAX::MRGATE!info-vax-request@kl.sri.com@SMTP 30-MAY-1988 09:52
To:	ARISIA::EVERHART
Subj:	User Open routine


Received: from ucbvax.Berkeley.EDU by KL.SRI.COM with TCP; Sat 28 May 88 02:02:22-PDT
Received: by ucbvax.Berkeley.EDU (5.59/1.28)
	id AA26060; Fri, 27 May 88 15:00:28 PDT
Received: from USENET by ucbvax.Berkeley.EDU with netnews
	for info-vax@kl.sri.com (info-vax@kl.sri.com)
	(contact usenet@ucbvax.Berkeley.EDU if you have questions)
Date: 27 May 88 19:37:22 GMT
From: dogie!dorl@speedy.cs.wisc.edu  (Michael Dorl)
Organization: University of Wisconsin Academic Computing Center
Subject: User Open routine
Message-Id: <301@dogie.edu>
Sender: info-vax-request@kl.sri.com
To: info-vax@kl.sri.com

I saw an article from dahls%vax.elab.unit.uninette@tor.nta.no
regarding user open routines and problems changing file protection.
Since I remember struggling with the same problem and since I can't
communicate directly with him I decided to post my user open routine.
I think the comments at the front are clear enough to allow you to
figure out how it works.

Michael Dorl (608) 262-0466
dorl@vms.macc.wisc.edu
dorl@wiscmacc.bitnet

-----------------------------------------------------------------------------

	Integer Function User_Open (Fab, Rab, Lun)

	Implicit None
 
	Include 'User_Open.Common'
	Include '($IODef)/list'

C Parameter Definitions

	Record /FABDef/ Fab
	Record /RABDef/ Rab
	Integer         Lun

C Description

C 	User_Open is designed to be called from a Fortran Open statement
C 	through a UserOpen clause.  Since it must do several different
C 	things, calls on it must be preceded with calls on User_Open_Init
C 	and User_Open_Param to tell it what needs to be done.  These
C 	routines have the same calling sequence...
C
C   	Call User_Open_Init (What_String, P1, P2, ... P8)
C   	Call User_Open_Init (What_String, P1, P2, ... P8)
C
C 	What_String tells what kind of action User_Open should take while
C 	P1 - P8 provide provide parameters for that action.
C
C   	What_String		Explanation
C
C   	'Status_New'        File to be created 
C   	'Status_Old'        File exists
C   	'Status_Unknown'    Use old file or create
C   	'Exec_Log'          Don't use user logicals
C   	'Protection'        Set protection to P1
C   	'Dup_Keys'          Allow duplicate keys for key P1

C External Definitions

	External Sys$Open, Sys$Create, Sys$Connect
	Integer  Sys$Open, Sys$Create, Sys$Connect
	external Sys$put, Sys$Close
	integer  Sys$put, Sys$Close

C Local Definitions

	Integer	*4	X, Off, Byte, XAB_Addr, XAB_Last
	Integer *2      Prot_IOSB
	Integer *4      XABSave
	Integer *4	Old_Prot

C Begin User_Open

	Unit = Lun			! save unit in common 
	LUNFab(Lun) = %Loc(FAB)

C Set exec mode translate

	If (LogNames) Then
	  X = PSL$C_EXEC
	  Off = FAB$V_LNm_Mode
	  Byte = Fab.FAB$B_ACModes
	  Call MvBits (X,0,FAB$S_LNm_Mode,Byte,Off)
	  Fab.FAB$B_AcModes = Byte
	EndIf

C Wander through all of the XAB's doing whatever needs to be done

	XAB_Last = 0
	XAB_Addr = Fab.FAB$L_XAB
	Do While (XAB_Addr .ne. 0)
	  XAB_Last = XAB_Addr
	  Call User_Open_XAB 
     $	    (%Val(XAB_Addr),
     $	     %Val(XAB_Addr),
     $       %Val(XAB_Addr),
     $       XAB_Addr
     $	    )
	EndDo

C If any options were not handled, handle them now!

	Call User_Open_XAB_Last (%Val(XAB_Last), Fab)

C Open the file

	If ((Status_Value .eq. 2) .or. (Status_Value .eq. 3)) Then
	  User_Open = Sys$Open (Fab)
	  If (User_Open) Then
	    What_Happened = 1
	    If (Prot_Active) Then
	      Old_Prot = LUNXABPro(Lun).XAB$W_Pro 
	      ! Put the protection flags back in the XAB since the
	      ! Open filled in existing values.
	      LUNXABPro(Lun).XAB$W_Pro = Prot_Value
	      If ((User_Open) .and. (Old_Prot .ne. Prot_Value)) Then
	        User_Open =  Sys$Close (Fab)
	        User_Open = Sys$Open (Fab)
	      EndIf
	    EndIf ! (Prot_Active)
	  EndIf ! (User_Open)
	EndIf

	If ((Status_Value .eq. 1) .or. 
     $      ((Status_Value .eq. 3) .and. (.not. User_Open))
     $     ) Then
	  User_Open = Sys$Create (Fab)
	  If (User_Open) Then
	    What_Happened = 2
	  EndIf
	EndIf

C If open worked, attach a record stream to it

	If (User_Open) Then
	  User_Open = Sys$Connect (RAB)
	  Call User_Open_Name (%Val(Fab.Fab$L_Nam))   ! Glom onto the name
	Else
	  What_Happened = 0
	EndIf

	User_Open_Status_Value = User_Open	! save status value for
						!  User_Open_Status


	End ! User_Open


	Subroutine User_Open_Init (What, P1, P2, P3, P4, P5, P6, P7, P8)

	Implicit None

	Include 'User_Open.Common'

C Description
C
C   Call User_Open_Init (What_String, P1, P2, ... P8)
C   Call User_Open_Init (What_String, P1, P2, ... P8)
C
C What_String tells what kind of action User_Open should take while
C P1 - P8 provide provide parameters for that action.
C
C   What_String		Explanation
C
C   'Status_New'        File to be created 
C   'Status_Old'        File exists
C   'Status_Unknown'    Use old file or create
C   'Exec_Log'          Don't use user logicals
C   'Protection'        Set protection to P1
C   'Dup_Keys'          Allow duplicate keys for key P1
C
C Parameter Definition

	Character *(*) What
	Integer   *4   P1, P2, P3, P4, P5, P6, P7, P8

C Local Definitions

	Integer *4      LWord
	Integer *2      Word
	Equivalence     (Word, LWord)

C Begin User_Open_Init

	Status = 0
	LogNames = 0
	Prot = 0
	Prot_Active = 0
	DupKeys = 0

C Begin User_open_Param

	Entry User_Open_Param (What, P1, P2, P3, P4, P5, P6, P7, P8)

	If      (What .eq. 'STATUS_NEW') Then
          Status = 1
          Status_Value = 1
	Else If (What .eq. 'STATUS_OLD') Then
          Status = 1
	  Status_Value = 2
	Else If (What .eq. 'STATUS_UNKNOWN') Then
	  Status = 1
	  Status_Value = 3
	Else If (What .eq. 'EXEC_LOG') Then
          LogNames = 1
	Else If (What .eq. 'PROTECTION') Then
          Prot = 1
	  Prot_Active = 1
	  LWord = P1			! nonsense to prevent 
	  Prot_Value = Word		! integer overflow
	Else If (What .eq. 'DUP_KEYS') Then
	  DupKeys = 1
	  DupKeys_Value = 1
	Else 
          Print '(A)', ' Unknown User_Open_Parameter: ' // What
          Call Lib$Stop (%Val(0))
	EndIf

	Return

	End ! User_Open_Init  User_Open_Param


	Subroutine User_Open_XAB (XABKey, XABPro, XAB, XAB_Ptr)

	Implicit None

	Include 'User_Open.Common'

C External Definitions

	Integer		  IOr

C Parameter Definitions

	Record /XABDef/      XAB
	Record /XABKeyDef/   XABKey
	Record /XABProDef1/  XABPro
	Integer              XAB_Ptr

C Local Definitions

	Integer		  T, B

C Begin User_Open_XAB

	If (DupKeys) Then
	  If (
     $         (XAB.XAB$B_Cod .eq. XAB$C_Key)
     $         .and. 
     $         (XABKey.XAB$B_Ref .eq. DupKeys_Value)
     $       )
     $	  Then
	    T = XAB$M_Dup
	    B = XABKey.XAB$B_Flg
	    B = IOr (B, T)
	    XABKey.XAB$B_Flg = B
	    DupKeys = 0
	  EndIf
	EndIf

	If (Prot) Then
	  If (XAB.XAB$B_Cod .eq. XAB$C_Pro) Then
	    XABPro.XAB$W_Pro = Prot_Value
	    Prot = 0
	  EndIf
	EndIf

	XAB_Ptr = XAB.XAB$L_Nxt

	End ! User_Open_XAB


	Subroutine User_Open_XAB_Last (XAB, FAB)

	Implicit None

	Include 'User_Open.Common'

C Parameter Definitions

	Record /XABDef/ XAB
	Record /FABDef/ FAB

c	Call User_Open_XAB_Last (%Val(XAB_Last), Fab)

C If end of XABs and Protection not already handled, chain on a new XAB

	If (Prot) Then
	  Call User_Open_XAB_Prot
     $      (%Val(%Loc(LUNXABPro(Unit))),
     $       %Val(%Loc(LUNXABPro(Unit))))
	  Prot = 0
	  If (%Loc(XAB) .ne. 0) Then
	    XAB.XAB$L_Nxt = %Loc(LUNXABPro(Unit))
	  Else
	    Fab.FAB$L_XAB = %Loc(LUNXABPro(Unit))
	  EndIf
	EndIf

	End ! User_Open_XAB_Last


	Subroutine User_Open_XAB_Prot (XAB, XABP)

	Implicit None
 
	Include 'User_Open.Common'

C Parameter Definition

	Record /XABDef/     XAB
	Record /XABProDef1/ XABP

C Begin User_Open_XAB_Prot

	Call Lib$Movc5 (0,0,0,XAB$C_ProLen,XAB)
	XAB.XAB$B_Cod = XAB$C_Pro
	XAB.XAB$B_BLN = XAB$C_ProLen
	XABP.XAB$W_Pro = Prot_Value

	Return

	End ! User_Open_XAB_Prot


	Subroutine User_Close (Lun)

	Implicit None

	Integer Lun

	Include 'User_Open.Common'

	Call User_Open_exfab (%Val(LunFab(Lun)))
	Call Sys$Close (%Val(LUNFAB(Lun)))

	End

	Subroutine user_open_exfab (fab)
	implicit none

	Include 'User_open.common'
	integer xab_addr
	Record /fabdef/ fab

	XAB_Addr = Fab.FAB$L_XAB
	Do While (XAB_Addr .ne. 0)
	  Call User_Open_exxab
     $	    (%Val(XAB_Addr),%Val(XAB_Addr),XAB_Addr)
	EndDo

	Return

	End

	Subroutine user_open_exxab (xab,xabpro,addr)
	implicit none
	include 'user_open.common'

	record /xabdef/ xab
	record /xabprodef1/ xabpro

        integer addr

	addr = XAB.XAB$L_Nxt

	return

	end


	Subroutine User_Open_Name (N)

	Implicit None

	Include '($NamDef)'

	Include 'User_Open.Common'

	Record /NamDef/ N

	Integer		A
	Integer		L

	A = N.Nam$L_ESA
	L = N.Nam$B_ESL
	Call User_Open_NameX (%Val(A), L)

	Return

	End ! User_Open_Name

	Subroutine User_Open_NameX (A, L)

	Implicit None

	Include 'User_Open.Common'

	Integer 	I

	Byte 		A(255)
        Integer 	L

	If ((%Loc(A) .eq. 0) .or. (L .eq. 0)) Then
	  Esa_Name = ' '
	  Esa_Name_L = 0
	Else
	  Do I = 1,L
	    Esa_Name(I:I) = Char(A(I))
	  EndDo
	  Esa_Name_L = L
	End If

	Return
	
	End ! User_Open_NameX


	Integer Function User_Open_Get_Status_Value ()

	Implicit None
 
	Include 'User_Open.Common'

	User_Open_Get_Status_Value = User_Open_Status_Value

	Return

	End


	Subroutine User_Open_Get_Name (S)

	Implicit None

	Include 'User_Open.Common'

	Character *(*) S

	Integer X

	X = ESA_Name_L
	If (X .gt. Len(S)) Then
	  X = Len(S)
	EndIf

	If (X .gt. 0) Then
	  S = ESA_Name(1:X)
	Else
	  S = ' '
	EndIf

	Return

	End ! User_Open_Get_Name


	Integer Function User_Open_Get_What_Happened 

	Implicit None

	Include 'User_Open.Common'

	User_Open_Get_What_Happened = What_Happened

	Return

	End ! User_Open_Get_What_Happened 


C Common Declarations to communicate between User_Open_Init/Param and
C User_Open

	Include '($XABDef)'
	Include '($XABKeyDef)'
	Include '($XABProDef)'
	Include '($FABDef)'
	Include '($RABDef)'
	Include '($PSLDef)'

	Integer  Status,   Status_Value      ! 1=new, 2=old, 3=unknown
	Integer  LogNames, LogNames_Value    !

	Integer  Prot			     ! protection flag
	Integer  *2        Prot_Value        !            mask
	Integer  	   Prot_Active       !            active

	Integer  DupKeys,  DupKeys_Value     ! duplicate key

	Record /XABProDef1/ LUNXABPro(100)
	Integer  *4        LUNFab(100)       ! LUN FAB Pointers
        Integer  *4        Unit		     ! Logical unit

	Integer  *4	   User_Open_Status_Value
					     ! Last status returned by
					     !  User_Open

	Character *256	   ESA_Name	     ! Resultant file name
	Integer  *4        ESA_Name_L	     !  Length of above

	Integer  *4        What_Happened     ! What happened on last open
					     !  0 = failed
					     !  1 = Open
					     !  2 = Create

	Common /User_Open_Common/
     $    Status,   Status_Value,
     $    LogNames, LogNames_Value,
     $    Prot,     Prot_Value,     Prot_Active,
     $	  DupKeys,  DupKeys_Value,
     $    LUNXABPro,LUNFAB,
     $    Unit,     User_Open_Status_Value,
     $    ESA_Name,ESA_Name_L, What_Happened
