MINICERN/packlib/kernlib/kerngen/ccgen/vaxsys/chdirf.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/02/15 17:49:29  mclareni
   6 * Kernlib
   7 *
   8 *
   9       INTEGER FUNCTION CHDIRF (CHNAME)
  10 C
  11 C CERN PROGLIB# Z265    CHDIRF          .VERSION KERNVAX  2.36  910306
  12 C ORIG.  31/07/90, Federico Carminati
  13 C MODIF. 25/02/91, Jamie Shiers,  to work in detached mode
  14 C
  15 C-    Simulate UNIX system call
  16
  17       INCLUDE '($LNMDEF)'
  18       STRUCTURE /ITMLST/
  19          UNION
  20             MAP
  21             INTEGER*2 BUFFER_LENGTH
  22             INTEGER*2 ITEM_CODE
  23             INTEGER*4 BUFFER_ADDRESS
  24             INTEGER*4 RETURN_LENGTH_ADDRESS
  25             ENDMAP
  26             MAP
  27             INTEGER*4 END_LIST /0/
  28             ENDMAP
  29          END UNION
  30       END STRUCTURE
  31
  32       RECORD /ITMLST/ LNM_LIST(2)
  33
  34       COMMON /SLATE/ ISTAT, ISLATE(39)
  35
  36       CHARACTER    CHNAME*(*), CHSTRI*255, CHLOGN*127
  37       LOGICAL      FIRST
  38       INTEGER*2    LIST2(2)
  39       INTEGER      LIST4(4), SYS$SETDDIR, SYS$TRNLNM, SYS$CRELNM
  40       EQUIVALENCE (LIST2, LIST4)
  41       DATA         LENRET/0/
  42
  43       CHSTRI=CHNAME
  44       FIRST=.TRUE.
  45       LENCHN=INDEX(CHNAME,' ')-1
  46       IF (LENCHN.LE.0) LENCHN=LEN(CHNAME)
  47 *
  48 *     Cater for users who like the <> characters as directory delimiters
  49 *
  50       CALL CTRANS('<','[',CHSTRI,1,LENCHN)
  51       CALL CTRANS('>',']',CHSTRI,1,LENCHN)
  52   10  IF (CHSTRI(1:1).NE.'[') THEN
  53         IF (INDEX(CHSTRI,':[') .NE. 0) THEN
  54 *
  55 *---        A directory and a device are specified
  56 *
  57 *         ISTAT=LIB$SET_LOGICAL('SYS$DISK',CHSTRI(1:INDEX(CHSTRI,':')),
  58 *    +                          'LNM$PROCESS')
  59
  60           LNM_LIST(1).BUFFER_LENGTH           = INDEX(CHSTRI,':')
  61           LNM_LIST(1).ITEM_CODE               = LNM$_STRING
  62           LNM_LIST(1).BUFFER_ADDRESS          = %LOC(CHSTRI)
  63           LNM_LIST(1).RETURN_LENGTH_ADDRESS   = %LOC(LENRET)
  64
  65           LNM_LIST(2).END_LIST                = 0
  66
  67           ISTAT=SYS$CRELNM(,'LNM$PROCESS','SYS$DISK',,LNM_LIST)
  68           IF(.NOT.ISTAT) GO TO 20
  69           CHSTRI=CHSTRI(INDEX(CHSTRI,'['):)
  70         ELSEIF (CHSTRI(LENCHN:LENCHN).EQ.':') THEN
  71 *
  72 *---        A device only is specified
  73 *
  74 *         ISTAT=LIB$SET_LOGICAL('SYS$DISK',CHSTRI(:LENCHN),
  75 *    +                          'LNM$PROCESS')
  76
  77           LNM_LIST(1).BUFFER_LENGTH           = LENCHN
  78           LNM_LIST(1).ITEM_CODE               = LNM$_STRING
  79           LNM_LIST(1).BUFFER_ADDRESS          = %LOC(CHSTRI)
  80           LNM_LIST(1).RETURN_LENGTH_ADDRESS   = %LOC(LENRET)
  81
  82           LNM_LIST(2).END_LIST                = 0
  83
  84           ISTAT=SYS$CRELNM(,'LNM$PROCESS','SYS$DISK',,LNM_LIST)
  85           GO TO 20
  86         ELSEIF (FIRST) THEN
  87           FIRST=.FALSE.
  88           LIST2(1)=LEN(CHLOGN)
  89           LIST2(2)=LNM$_STRING
  90           LIST4(2)=%LOC(CHLOGN)
  91           LIST4(3)=%LOC(LENCH)
  92           LIST4(4)=0
  93           ISTAT = SYS$TRNLNM(LNM$M_CASE_BLIND,'LNM$FILE_DEV',
  94      +           CHSTRI(1:INDEX(CHSTRI,' ')-1),,LIST2)
  95           IF(.NOT.ISTAT) GO TO 20
  96           CHSTRI=CHLOGN(:LENCH)
  97           GO TO 10
  98         ELSE
  99           ISTAT=0
 100           GO TO 20
 101         END IF
 102       END IF
 103       ISTAT = SYS$SETDDIR(CHSTRI, %VAL(0), %VAL(0))
 104   20  IF (ISTAT)  THEN
 105         ISTAT = 0
 106         IRET = 0
 107       ELSE
 108         IRET = -1
 109       ENDIF
 110       CHDIRF = IRET
 111       RETURN
 112       END