(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)


(FILECREATED "22-Sep-2023 15:29:50" {WMEDLEY}<lispusers>PSEUDOHOSTS.;158
 26638  

      :EDIT-BY rmk

      :CHANGES-TO (FNS PSEUDOHOST SLASHIT CONTRACT.PH)
                  (VARS PSEUDOHOSTSCOMS)

      :PREVIOUS-DATE "26-Jul-2023 12:34:37" {WMEDLEY}<lispusers>PSEUDOHOSTS.;155)


(PRETTYCOMPRINT PSEUDOHOSTSCOMS)

(RPAQQ PSEUDOHOSTSCOMS

       (
        (* ;; "Public entries")


        (FNS PSEUDOHOST PSEUDOHOSTP PSEUDOHOSTS TARGETHOST TRUEFILENAME PSEUDOFILENAME)
        
        (* ;; "Internals")


        (FNS EXPAND.PH CONTRACT.PH UNSLASHIT GETHOSTINFO.PH)
        (FNS OPENFILE.PH GETFILENAME.PH DIRECTORYNAMEP.PH CLOSEFILE.PH REOPENFILE.PH DELETEFILE.PH 
             OPENP.PH UNREGISTERFILE.PH REGISTERFILE.PH GENERATEFILES.PH GETFILEINFO.PH 
             SETFILEINFO.PH NEXTFILEFN.PH FILEINFOFN.PH RENAMEFILE.PH)
        (P (PSEUDOHOST 'LI LOGINHOST/DIR)
           (MOVD? 'GETHOSTINFO 'GETHOSTINFO.ORIG)
           (MOVD 'GETHOSTINFO.PH 'GETHOSTINFO))
        (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS PHDEVICE PHGENFILESTATE TARGETDEVICE)
               (MACROS PSEUDOHOST.NAME PSEUDOHOST.TARGETVAL)
               (FILES (FROM LOADUPS)
                      EXPORTS.ALL))))



(* ;; "Public entries")


(DEFINEQ

(PSEUDOHOST

  [LAMBDA (HOST PREFIX)

    (* ;; "Edited 22-Sep-2023 15:29 by rmk")


    (* ;; "Edited 25-Jun-2022 17:00 by rmk")


    (* ;; "Edited 24-Feb-2022 23:56 by rmk: Expand prefix so that it is rooted in a real host and not a previously defined pseudohost.")


    (CL:WHEN (AND (LISTP HOST)
                  (NULL PREFIX))
        (SETQ PREFIX (CADR HOST))
        (SETQ HOST (CAR HOST)))
    (CL:WHEN (EQ (CHCON1 HOST)
                 (CHARCODE {))
        (SETQ HOST (SUBSTRING HOST 2)))
    (CL:WHEN (EQ (NTHCHARCODE HOST -1)
                 (CHARCODE }))
        (SETQ HOST (SUBSTRING HOST 1 -2)))
    (SETQ HOST (U-CASE (MKATOM HOST)))
    [if
 PREFIX
        then
 (CL:WHEN (PSEUDOHOSTP
 HOST)                     (* ; 

                                                       "Redefining: first clear out the previous one")

                 (PSEUDOHOST
 HOST NIL))
             [LET (TARGETHOST
 TARGETDEVICE PREFIXHOST)
                  (CL:UNLESS [SETQ PREFIXHOST (U-CASE (FILENAMEFIELD PREFIX 'HOST]
                      (SETQ PREFIX (UNSLASHIT
 (PACKFILENAME 'HOST (SETQ PREFIXHOST 'DSK)
                                                     'BODY PREFIX))))

                  (* ;; "We want the maximal prefix. If {LI} is a pseudohost with prefix {DSK}<abc> and we are defining {FOO} with prefix {LI}<xyz>, we want FOO's prefix to be {DSK}<abc>xyz>. ,  And if FUM is then defined as {FOO}<mno>, we want its prefix to be {DSK}<abc>xyz>mno>.  This gives the true filenames.")


                  (SETQ PREFIX (EXPAND.PH
 PREFIX PREFIXHOST))
                  (CL:UNLESS (MEMB (NTHCHARCODE PREFIX -1)
                                   (CHARCODE (> / <)))
                      (SETQ PREFIX (CONCAT PREFIX (IF
 (STRPOS "/" PREFIX)
                                                      THEN
 "/"
                                                    ELSE
 ">"))))
                  [SETQ TARGETHOST (U-CASE (FILENAMEFIELD PREFIX 'HOST]

                  (* ;; "We know about the directory separators for these particular devices.  Maybe there should be separate list of slash-hosts somewhere that we can use.")


                  (SELECTQ TARGETHOST
                      ((DSK CORE) 
                           (SETQ PREFIX (UNSLASHIT
 PREFIX)))
                      (UNIX (SETQ PREFIX (SLASHIT PREFIX)))
                      NIL)
                  (SETQ TARGETDEVICE (OR (\GETDEVICEFROMHOSTNAME TARGETHOST)
                                         (ERROR "UNKNOWN TARGET HOST" TARGETHOST)))

                  (* ;; "Save the last directory marker to pack on if needed.")


                  (\DEFINEDEVICE HOST
                         (create
 FDEV
                            using
 TARGETDEVICE DEVICENAME _ HOST FDEV1 _ TARGETDEVICE FDEV2 _ PREFIX
                                  OPENFILELST _ NIL OPENFILE _ (FUNCTION OPENFILE.PH)
                                  GETFILENAME _ (FUNCTION GETFILENAME.PH)
                                  DIRECTORYNAMEP _ (FUNCTION DIRECTORYNAMEP.PH)
                                  CLOSEFILE _ (FUNCTION CLOSEFILE.PH)
                                  REOPENFILE _ (FUNCTION REOPENFILE.PH)
                                  DELETEFILE _ (FUNCTION DELETEFILE.PH)
                                  OPENP _ (FUNCTION \GENERIC.OPENP)
                                  UNREGISTERFILE _ (FUNCTION \GENERIC-UNREGISTER-STREAM)
                                  REGISTERFILE _ (FUNCTION \ADD-OPEN-STREAM)
                                  GENERATEFILES _ (FUNCTION GENERATEFILES.PH)
                                  GETFILEINFO _ (FUNCTION GETFILEINFO.PH)
                                  SETFILEINFO _ (FUNCTION SETFILEINFO.PH)
                                  RENAMEFILE _ (FUNCTION RENAMEFILE.PH)))

                  (* ;; "The ultimate target device keeps a map of prefixes and the hostnames they map to.  The longest matching prefix is chosen when a name that expands to the target device is contracted.")


                  (change
 (fetch
 (TARGETDEVICE PREFIXMAP) OF
 TARGETDEVICE)
                         (SORT (CONS (LIST PREFIX HOST (CL:IF (EQ (CHARCODE /)
                                                                  (NTHCHARCODE PREFIX -1))
                                                           '/
                                                           '<))
                                     DATUM)
                               (FUNCTION (LAMBDA (P1 P2)
                                           (IGREATERP (NCHARS (CAR P1))
                                                  (NCHARS (CAR P2]
      elseif
 (SETQ PREFIX (CADR (PSEUDOHOSTP
 HOST)))
        then
 
             (* ;; "\DEFINEDEVICE removes the name-mapping but doesn't remove the device.  Maybe that's on purpose for other devices, but not here.")


             (LET* ((PHHOST (\GETDEVICEFROMNAME HOST \FILEDEVICES))
                    (TARGETDEV (fetch
 (PHDEVICE TARGETDEV) OF
 PHHOST)))
                   (UNINTERRUPTABLY
                       (CL:WHEN TARGETDEV                    (* ; 

                                                             "Don't want to fail uninterruptably")

                           (CHANGE
 (FETCH
 (TARGETDEVICE PREFIXMAP) OF
 TARGETDEV)
                                  (DREMOVE (ASSOC PREFIX DATUM)
                                         DATUM)))
                       (SETQ \FILEDEVICES (DREMOVE PHHOST \FILEDEVICES))
                       (\DEFINEDEVICE HOST NIL))]
    HOST])

(PSEUDOHOSTP

  [LAMBDA (HOST)
                                             (* ; "Edited 24-Feb-2022 23:51 by rmk")


                                                             (* ; "Edited 18-Jan-2022 11:29 by rmk")

    (LET ((DEV (\GETDEVICEFROMNAME HOST T T)))
         (CL:WHEN (AND DEV (type?
 FDEV (fetch
 (PHDEVICE TARGETDEV) OF
 DEV)))
             (LIST (FETCH
 (FDEV DEVICENAME) OF
 DEV)
                   (FETCH
 (PHDEVICE PREFIX)
                          DEV)))])

(PSEUDOHOSTS

  [LAMBDA NIL
                                                (* ; "Edited 17-Jan-2022 18:15 by rmk")

    (FOR
 DEV IN
 \FILEDEVICES WHEN
 (TYPE?
 FDEV (FETCH
 (PHDEVICE TARGETDEV) OF
 DEV))
       COLLECT
 (LIST (FETCH
 (FDEV DEVICENAME) OF
 DEV)
                     (FETCH
 (PHDEVICE PREFIX) OF
 DEV])

(TARGETHOST

  [LAMBDA (HOST)
                                             (* ; "Edited 22-Jan-2022 09:00 by rmk")

    (CL:WHEN (PSEUDOHOSTP
 HOST)
        (FETCH
 (FDEV DEVICENAME) OF
 (FETCH
 (PHDEVICE TARGETDEV) OF
 (\GETDEVICEFROMNAME HOST))))])

(TRUEFILENAME

  [LAMBDA (FILE)
                                             (* ; "Edited 26-Jul-2023 07:53 by rmk")


                                                             (* ; "Edited 26-Jan-2022 23:33 by rmk")


                                                             (* ; "Edited 25-Jan-2022 08:47 by rmk")

    (if
 (LISTP FILE)
        then
 (for
 F in
 FILE collect
 (TRUEFILENAME
 F))
      else
 (LET (FILENAME DEVICE)
                (IF
 (STREAMP FILE)
                    THEN
 (SETQ FILENAME (FETCH
 (STREAM FULLFILENAME) OF
 FILE))
                         (SETQ DEVICE (FETCH
 (STREAM DEVICE) OF
 FILE))
                  ELSE
 (SETQ FILENAME (\ADD.CONNECTED.DIR FILE))
                       (SETQ DEVICE (\GETDEVICEFROMNAME FILENAME)))
                (CL:IF (TYPE?
 PHDEVICE DEVICE)
                    (EXPAND.PH
 FILENAME DEVICE)
                    FILENAME)])

(PSEUDOFILENAME

  [LAMBDA (FILE)
                                             (* ; "Edited 26-Jul-2023 12:34 by rmk")


                                                             (* ; "Edited 29-Jan-2022 23:08 by rmk")


                                                             (* ; "Edited 28-Jan-2022 09:06 by rmk")

    (if
 (LISTP FILE)
        then
 (for
 F in
 FILE collect
 (PSEUDOFILENAME
 F))
      else
 (FOR
 D PN (FILENAME _ (IF
 (STREAMP FILE)
                                     THEN
 (FETCH
 (STREAM FULLFILENAME) OF
 FILE)
                                   ELSE
 (\ADD.CONNECTED.DIR FILE))) IN
 \FILEDEVICES
              WHEN
 (TYPE?
 PHDEVICE D) UNLESS
 (EQ FILENAME (SETQ PN (CONTRACT.PH
 FILENAME D)))
              DO
 (RETURN PN) FINALLY
 (RETURN FILENAME])
)



(* ;; "Internals")


(DEFINEQ

(EXPAND.PH

  [LAMBDA (FILENAME PHDEV)

    (* ;; "Edited 25-Apr-2022 09:35 by rmk: that FILENAME contains }, because HOST was identified in it.  If FILENAME is a stream, expand its full name")


    (* ;; "Assumes that FILENAME contains }, because HOST was identified in it.  If FILENAME is a stream, expand its full name")


    [IF
 (TYPE?
 STREAM FILENAME)
        THEN
 (CL:UNLESS PHDEV
                 (SETQ PHDEV (FETCH
 (STREAM DEVICE) OF
 FILENAME)))
             (SETQ FILENAME (FETCH
 (STREAM FULLNAME) OF
 FILENAME))
      ELSEIF
 (NOT (TYPE?
 FDEV PHDEV))
        THEN
 (SETQ PHDEV (\GETDEVICEFROMNAME (OR PHDEV FILENAME]
    (IF
 (TYPE?
 PHDEVICE PHDEV)
        THEN
 (LET (SUFFIX SUFFIXPOS)
                  (CL:WHEN (SETQ SUFFIXPOS (STRPOS "}" FILENAME))
                      (SETQ SUFFIX (OR (SUBSTRING FILENAME (ADD1 SUFFIXPOS))
                                       ""))
                      (CL:WHEN (FMEMB (CHCON1 SUFFIX)
                                      (CHARCODE (< > /)))
                          (SETQ SUFFIX (SUBSTRING SUFFIX 2)))
                      (CONCAT (FETCH
 (PHDEVICE PREFIX) OF
 PHDEV)
                             SUFFIX)))
      ELSE
 FILENAME])

(CONTRACT.PH

  [LAMBDA (NAME PHDEV)

    (* ;; "Edited 22-Sep-2023 14:30 by rmk")


    (* ;; "Edited 30-Jan-2022 00:20 by rmk: the smallest pseudoname for NAME.  If the NAME was constructed by expanding, then")


    (* ;; "Finds the smallest pseudoname for NAME.  The PHDEV is used only to find its targetdev, that's where we scan for matching prefixes.  This is so we can find the lowest matching pseudohost in the target's prefix map.  If the hosts are defined as {DSK}...{H1}...{H2}, DSK knows the prefixes that lead to H1 and H2, picks the longest matching prefix and replaces it by the corresponding host.")


    (* ;; "If pseudohosts are defined in terms of other pseudohosts (e.g. FUM is defined in terms of FOO which is defined in terms of LI which is rooted in DSK, then the pseudodevices presumably were created in that order, so the first name we encounter will be the one with the longest prefix.  So {DSK}... might collapse to {FUM}.  But {FOO}... will not.  ")


    (CL:UNLESS (TYPE?
 FDEV PHDEV)
        (SETQ PHDEV (\GETDEVICEFROMNAME PHDEV)))
    (CL:WHEN NAME
        (FOR
 PM PREFIX SUFFIX CONNECTOR IN
 (FETCH
 (TARGETDEVICE PREFIXMAP) OF
 (FETCH
 (PHDEVICE 
                                                                                            TARGETDEV
                                                                                            )
                                                                                 OF
 PHDEV))
           WHEN
 (STRPOS (SETQ PREFIX (CAR PM))
                       NAME 1 NIL T NIL FILEDIRCASEARRAY)
           DO
 
              (* ;; "This is the lowest host.  ")


              [SETQ SUFFIX (SUBSTRING NAME (ADD1 (NCHARS PREFIX]
              (CL:WHEN (STRPOS ">" SUFFIX 1 NIL NIL NIL FILEDIRCASEARRAY)

                  (* ;; "CONNECTOR tells us whether to use / or > depending on what the  prefix has")


                  (SETQ CONNECTOR (CADDR PM))
                  [SETQ SUFFIX (CONCAT CONNECTOR (IF
 (EQ CONNECTOR '/)
                                                     THEN
 (SLASHIT SUFFIX)
                                                   ELSE
 (UNSLASHIT
 SUFFIX])
              (RETURN (PACK* '{ (CADR PM)
                             "}"
                             (OR SUFFIX ""))) FINALLY
 

                                 (* ;; "If we didn't match a prefix, then this was not related to any pseudhost descending from the target, it is a pure target name, presumably because something like a relative .. reference took it off all paths.  We return the original name.")


                                                    (RETURN NAME)))])

(UNSLASHIT

  [LAMBDA (X LCASEDIRS)
                                      (* ; "Edited 26-Jan-2022 15:09 by rmk")


                                                             (* ; "Edited 22-Dec-2021 20:18 by rmk")


                                                            (* ; "Edited 21-Nov-2021 23:00 by rmk:")


    (* ;; "Tricky to get the first one right.")


    (LET [LASTDIRPOS UNSLASHED (DIRPOS (ADD1 (OR (STRPOS "}" X)
                                                 0]
         [SETQ UNSLASHED
          (CONCATCODES (FOR
 I C LASTC FROM
 DIRPOS WHILE
 (SETQ C (NTHCHARCODE X I))
                          COLLECT
 (PROG1 (SELCHARQ C
                                              (/ (SETQ LASTDIRPOS I)
                                                 (IF
 (AND LASTC (NEQ LASTC (CHARCODE })))
                                                     THEN
 (CHARCODE >)
                                                   ELSE
 (CHARCODE <)))
                                              ((< >) 
                                                   (SETQ LASTDIRPOS I)
                                                   C)
                                              C)
                                         (SETQ LASTC C]
         (CL:WHEN (AND LCASEDIRS LASTDIRPOS)
             (SETQ LASTDIRPOS (ADD1 (IDIFFERENCE LASTDIRPOS DIRPOS)))
             (SETQ UNSLASHED (CONCAT (L-CASE (SUBSTRING UNSLASHED 1 LASTDIRPOS))
                                    (OR (SUBSTRING UNSLASHED (ADD1 LASTDIRPOS))
                                        ""))))
         (CL:IF (EQ DIRPOS 1)
             UNSLASHED
             (CONCAT (SUBSTRING X 1 (SUB1 DIRPOS))
                    UNSLASHED))])

(GETHOSTINFO.PH

  [LAMBDA (HOST ATTRIBUTE)

    (* ;; "Edited 24-Apr-2022 14:16 by rmk: the  info from the true host")


    (* ;; "Want the  info from the true host")


    (GETHOSTINFO.ORIG (OR (TARGETHOST
 HOST)
                          HOST)
           HOST ATTRIBUTE])
)
(DEFINEQ

(OPENFILE.PH

  [LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTRING)

    (* ;; "Edited 31-Oct-2022 23:32 by rmk")


    (* ;; "Edited 14-Jul-2022 17:53 by rmk")


    (* ;; "Edited 25-Jun-2022 17:06 by rmk:  If the stream was opened through the pseudohost, then it should only be registered on the pseudohost.  We assume that it is safe to remove it from the target hosts list.  The goal is that OPENP should only see it once, as being open on the pseudohost.")


    (* ;; "Edited 25-Jan-2022 08:45 by rmk")


    (* ;; "Edited 18-Jan-2022 10:29 by rmk")


    (LET ((TARGETDEV (FETCH
 (PHDEVICE TARGETDEV) OF
 FDEV))
          (STREAM (PSEUDOHOST.TARGETVAL OPENFILE (FILE ACCESS RECOG OTHERINFO FDEV OLDSTRING)
                         FDEV)))
         (CL:WHEN STREAM
             (FDEVOP 'UNREGISTERFILE TARGETDEV TARGETDEV STREAM)
             (CHANGE
 (FETCH
 (STREAM FULLFILENAME) OF
 STREAM)
                    (CONTRACT.PH
 DATUM FDEV))
             (REPLACE
 (STREAM DEVICE) OF
 STREAM WITH
 FDEV))
         STREAM])

(GETFILENAME.PH

  [LAMBDA (NAME RECOG FDEV)
                                  (* ; "Edited 25-Jan-2022 22:56 by rmk")


                                                             (* ; "Edited 16-Jan-2022 20:27 by rmk")

    (PSEUDOHOST.NAME GETFILENAME (NAME RECOG FDEV])

(DIRECTORYNAMEP.PH

  [LAMBDA (DIRSPEC DEV CREATE?)
                              (* ; "Edited 25-Jan-2022 22:56 by rmk")


                                                             (* ; "Edited 18-Jan-2022 11:32 by rmk")


    (* ;; "{FOO} by itself is always a legitimate directory--you should be able to connect to it when you are starting up")


                                                             (* ; "Edited 16-Jan-2022 20:35 by rmk")

    (OR (EQ (CHARCODE })
            (NTHCHARCODE DIRSPEC -1))
        (PSEUDOHOST.NAME DIRECTORYNAMEP (DIRSPEC DEV CREATE?)
               DEV])

(CLOSEFILE.PH

  [LAMBDA (STREAM ABORTFLG)
                                  (* ; "Edited 25-Jun-2022 14:38 by rmk")


                                                             (* ; "Edited 16-Jan-2022 15:38 by rmk")

    (APPLY* (FETCH
 (FDEV CLOSEFILE) OF
 (FETCH
 (PHDEVICE TARGETDEV) OF
 (FETCH
 (STREAM DEVICE)
                                                                         OF
 STREAM)))
           STREAM ABORTFLG])

(REOPENFILE.PH

  [LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM)
       (* ; "Edited 25-Jan-2022 12:50 by rmk")


                                                             (* ; "Edited 18-Jan-2022 11:41 by rmk")

    (LET ((STREAM (PSEUDOHOST.TARGETVAL REOPENFILE (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM)
                         FDEV)))
         (CHANGE
 (FETCH
 (STREAM FULLFILENAME) OF
 STREAM)
                (CONTRACT.PH
 DATUM FDEV))
         (REPLACE
 (STREAM DEVICE) OF
 STREAM WITH
 FDEV)
         STREAM])

(DELETEFILE.PH

  [LAMBDA (FILENAME DEV)
                                     (* ; "Edited 25-Jan-2022 22:56 by rmk")


                                                             (* ; "Edited 18-Jan-2022 10:23 by rmk")

    (PSEUDOHOST.NAME DELETEFILE (FILENAME DEV])

(OPENP.PH

  [LAMBDA (FILENAME ACCESS DEVICE)

    (* ;; "Edited 25-Jun-2022 15:48 by rmk: No longer called.  Streams are registered in the pseudohost, not in the target device.")


    (* ;; "Edited 18-Jan-2022 10:29 by rmk")


    (PSEUDOHOST.TARGETVAL OPENP (FILENAME ACCESS DEVICE])

(UNREGISTERFILE.PH

  [LAMBDA (DEVICE STREAM)
                                    (* ; "Edited 25-Jun-2022 15:07 by rmk")


                                                             (* ; "Edited 16-Jan-2022 16:47 by rmk")


    (* ;; 

   "This isn't called now because files are now registered in the pseudohost, not the target device.")


    (APPLY* (FETCH
 (FDEV UNREGISTERFILE) OF
 (FETCH
 (PHDEVICE TARGETDEV) OF
 DEVICE))
           (FETCH
 (PHDEVICE TARGETDEV) OF
 DEVICE)
           STREAM])

(REGISTERFILE.PH

  [LAMBDA (DEVICE STREAM)
                                    (* ; "Edited 25-Jun-2022 15:07 by rmk")


                                                             (* ; "Edited 16-Jan-2022 16:46 by rmk")


    (* ;; "This isn't called now, because the stream is registered in the pseudohost, not in the target device.")


    (APPLY* (FETCH
 (FDEV REGISTERFILE) OF
 (FETCH
 (PHDEVICE TARGETDEV) OF
 DEVICE))
           (FETCH
 (PHDEVICE TARGETDEV) OF
 DEVICE)
           STREAM])

(GENERATEFILES.PH

  [LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS)
                (* ; "Edited 17-Jan-2022 20:46 by rmk")


    (* ;; "FDEV is the pseudohost. We will generate from the target directory using its GENFILESTATE, but fiddle the output so that it looks like it is coming from the pseudo host.")


    (LET ((TARGETGENOBJ (APPLY* (FETCH
 (FDEV GENERATEFILES) OF
 (FETCH
 (PHDEVICE TARGETDEV)
                                                                  OF
 FDEV))
                               (FETCH
 (PHDEVICE TARGETDEV) OF
 FDEV)
                               (EXPAND.PH
 PATTERN FDEV)
                               DESIREDPROPS OPTIONS)))

         (* ;; "The TARGETGENOBJ contains the targets functions as well as its GENFILESTATE.  We need the ph FDEV to contract the generated names")


         (CREATE
 FILEGENOBJ
                NEXTFILEFN _ (FUNCTION NEXTFILEFN.PH)
                FILEINFOFN _ (FUNCTION FILEINFOFN.PH)
                GENFILESTATE _ (LIST FDEV TARGETGENOBJ])

(GETFILEINFO.PH

  [LAMBDA (STREAM ATTRIBUTE DEVICE)
                          (* ; "Edited 25-Jan-2022 12:43 by rmk")


                                                             (* ; "Edited 17-Jan-2022 18:21 by rmk")

    (PSEUDOHOST.TARGETVAL GETFILEINFO (STREAM ATTRIBUTE DEVICE])

(SETFILEINFO.PH

  [LAMBDA (STREAM ATTRIBUTE VALUE DEVICE)
                    (* ; "Edited 25-Jan-2022 12:37 by rmk")

    (PSEUDOHOST.TARGETVAL SETFILEINFO (STREAM ATTRIBUTE VALUE DEVICE])

(NEXTFILEFN.PH

  [LAMBDA (GENFILESTATE NAMEONLY)
                            (* ; "Edited 17-Jan-2022 21:27 by rmk")

    (LET* ((TARGETGENOBJ (CADR GENFILESTATE))
           (TARGETGENFILESTATE (FETCH
 GENFILESTATE OF
 TARGETGENOBJ))
           (FILENAME (APPLY* (FETCH
 NEXTFILEFN OF
 TARGETGENOBJ)
                            TARGETGENFILESTATE NAMEONLY)))
          (CL:WHEN FILENAME
              (CL:UNLESS NAMEONLY
                  (SETQ FILENAME (CONTRACT.PH
 FILENAME (CAR GENFILESTATE)))))
          FILENAME])

(FILEINFOFN.PH

  [LAMBDA (GENFILESTATE ATTRIBUTE)
                           (* ; "Edited 17-Jan-2022 20:52 by rmk")

    (APPLY* (FETCH
 FILEINFOFN OF
 (CADR GENFILESTATE))
           (FETCH
 GENFILESTATE OF
 (CADR GENFILESTATE))
           ATTRIBUTE])

(RENAMEFILE.PH

  [LAMBDA (OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME)
          (* ; "Edited 18-Jan-2022 09:52 by rmk")

    (LET ((OLDTARGETDEV (FETCH
 (PHDEVICE TARGETDEV) OF
 OLD-DEVICE))
          (NEWTARGETDEV (FETCH
 (PHDEVICE TARGETDEV) OF
 NEW-DEVICE))
          (NEWTARGETNAME NEW-NAME)
          RESULT)
         (CL:WHEN (TYPE?
 FDEV NEWTARGETDEV)                  (* ; "NEW-DEVICE is a pseudo host")

             (SETQ NEWTARGETNAME (EXPAND.PH
 NEW-NAME NEW-DEVICE)))
         (SETQ RESULT (APPLY* (FETCH
 (FDEV RENAMEFILE) OF
 OLDTARGETDEV)
                             OLDTARGETDEV
                             (EXPAND.PH
 OLD-NAME OLD-DEVICE)
                             (OR NEWTARGETDEV NEW-DEVICE)
                             NEWTARGETNAME))
         (CL:WHEN (AND RESULT (NEQ NEWTARGETDEV NEW-DEVICE))
             (SETQ RESULT (CONTRACT.PH
 RESULT NEW-DEVICE)))
         RESULT])
)

(PSEUDOHOST
 'LI LOGINHOST/DIR)

(MOVD? 'GETHOSTINFO 'GETHOSTINFO.ORIG)

(MOVD 'GETHOSTINFO.PH 'GETHOSTINFO)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE

(ACCESSFNS PHDEVICE
 ((PREFIX (FETCH
 (FDEV FDEV2) OF
 DATUM))
                     (TARGETDEV (FETCH
 (FDEV FDEV1) OF
 DATUM)
                            (REPLACE
 (FDEV FDEV1) OF
 DATUM WITH
 NEWVALUE)))
                    (TYPE?
 (FETCH
 (PHDEVICE PREFIX) OF
 DATUM)))

(RECORD PHGENFILESTATE
 (PHDEVICE . TARGETGENFILESTATE))

(ACCESSFNS TARGETDEVICE
 ((PREFIXMAP (FETCH
 (FDEV FDEV3) OF
 DATUM)
                                (REPLACE
 (FDEV FDEV3) OF
 DATUM WITH
 NEWVALUE))))
)

(DECLARE%: EVAL@COMPILE 

(PUTPROPS PSEUDOHOST.NAME
 MACRO

          [TAIL (LET [(OPNAME (CAR TAIL))
                      (ARGS (CADR TAIL))
                      (DEV (OR (CADDR TAIL)
                               (CAR (LAST (CADR TAIL]

                     (* ;; 

    "Assumes that the name is (CAR ARGS), the device is the last or args if not specified separately")


                     `(CONTRACT.PH
 [APPLY* (FETCH
 (FDEV ,OPNAME) OF
 (FETCH
 (PHDEVICE TARGETDEV)
                                                                       OF
 ,DEV))
                                          (EXPAND.PH
 ,(CAR ARGS)
                                                 ,DEV)
                                          ,@(SUBST `(FETCH
 (PHDEVICE TARGETDEV) OF
 ,DEV)
                                                   DEV
                                                   (CDR ARGS]
                             ,DEV])

(PUTPROPS PSEUDOHOST.TARGETVAL
 MACRO

          [TAIL (LET [(OPNAME (CAR TAIL))
                      (ARGS (CADR TAIL))
                      (DEV (OR (CADDR TAIL)
                               (CAR (LAST (CADR TAIL]

                     (* ;; "Assumes that the name is (CAR ARGS), the device is the last or args if not specified separately.  Unlike PSEUDOHOST.OP, this returns the target value, doesn't assume it is a name to be contracted.")


                     `(APPLY* (FETCH
 (FDEV ,OPNAME) OF
 (FETCH
 (PHDEVICE TARGETDEV)
                                                          OF
 ,DEV))
                             (EXPAND.PH
 ,(CAR ARGS)
                                    ,DEV)
                             ,@(SUBST `(FETCH
 (PHDEVICE TARGETDEV) OF
 ,DEV)
                                      DEV
                                      (CDR ARGS])
)


(FILESLOAD (FROM
 LOADUPS)
       EXPORTS.ALL)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1315 9921 (PSEUDOHOST 1325 . 6930) (PSEUDOHOSTP 6932 . 7445) (PSEUDOHOSTS 7447 . 7808) 
(TARGETHOST 7810 . 8084) (TRUEFILENAME 8086 . 9048) (PSEUDOFILENAME 9050 . 9919)) (9949 15964 (
EXPAND.PH 9959 . 11212) (CONTRACT.PH 11214 . 13925) (UNSLASHIT 13927 . 15673) (GETHOSTINFO.PH 15675 . 
15962)) (15965 23985 (OPENFILE.PH 15975 . 17048) (GETFILENAME.PH 17050 . 17339) (DIRECTORYNAMEP.PH 
17341 . 17965) (CLOSEFILE.PH 17967 . 18434) (REOPENFILE.PH 18436 . 19001) (DELETEFILE.PH 19003 . 19287
) (OPENP.PH 19289 . 19584) (UNREGISTERFILE.PH 19586 . 20128) (REGISTERFILE.PH 20130 . 20664) (
GENERATEFILES.PH 20666 . 21710) (GETFILEINFO.PH 21712 . 22014) (SETFILEINFO.PH 22016 . 22215) (
NEXTFILEFN.PH 22217 . 22763) (FILEINFOFN.PH 22765 . 23040) (RENAMEFILE.PH 23042 . 23983)))))
STOP