New function PSEUDOHOSTNAMES returns a list of alternative designators for a given file
This commit is contained in:
rmkaplan
@@ -1,16 +1,14 @@
|
||||
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
|
||||
|
||||
(FILECREATED "26-Apr-2026 10:31:30" {MEDLEY}<library>PSEUDOHOSTS.;188 29278
|
||||
(FILECREATED "27-Apr-2026 21:16:52" {WMEDLEY}<library>PSEUDOHOSTS.;189 30476
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS CONTRACT.PH PSEUDOFILENAME OPENFILE.PH REOPENFILE.PH CDPSEUDO DELETEFILE.PH
|
||||
NEXTFILEFN.PH GENERATEFILES.PH GETFILENAME.PH GETFILEINFO.PH
|
||||
CONTRACT.PH.PREFIXMAP RENAMEFILE.PH PSEUDOHOST SETFILEINFO.PH)
|
||||
(MACROS PSEUDOHOST.NAME)
|
||||
:CHANGES-TO (FNS CONTRACT.PH PSEUDOHOST PSEUDOHOSTP PSEUDOFILENAME EXPAND.PH PSEUDOFILENAMES)
|
||||
(VARS PSEUDOHOSTSCOMS)
|
||||
(RECORDS TARGETDEVICE)
|
||||
|
||||
:PREVIOUS-DATE "26-Nov-2025 17:26:18" {MEDLEY}<library>PSEUDOHOSTS.;182)
|
||||
:PREVIOUS-DATE "26-Apr-2026 10:31:30" {MEDLEY}<library>PSEUDOHOSTS.;188)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT PSEUDOHOSTSCOMS)
|
||||
@@ -19,7 +17,8 @@
|
||||
(
|
||||
(* ;; "Public entries")
|
||||
|
||||
(FNS PSEUDOHOST PSEUDOHOSTP PSEUDOHOSTS TARGETHOST TRUEDEVICE TRUEFILENAME PSEUDOFILENAME)
|
||||
(FNS PSEUDOHOST PSEUDOHOSTP PSEUDOHOSTS TARGETHOST TRUEDEVICE TRUEFILENAME PSEUDOFILENAME
|
||||
PSEUDOFILENAMES)
|
||||
(FNS CDPSEUDO)
|
||||
|
||||
(* ;; "Internals")
|
||||
@@ -41,6 +40,8 @@
|
||||
(PSEUDOHOST
|
||||
[LAMBDA (HOST PREFIX CDSUFFIX NOERROR)
|
||||
|
||||
(* ;; "Edited 27-Apr-2026 17:33 by rmk")
|
||||
|
||||
(* ;; "Edited 25-Apr-2026 15:51 by rmk")
|
||||
|
||||
(* ;; "Edited 2-Feb-2025 10:05 by rmk")
|
||||
@@ -73,7 +74,7 @@
|
||||
(CL:WHEN (PSEUDOHOSTP HOST) (* ;
|
||||
"Redefining: first clear out the previous one")
|
||||
(PSEUDOHOST HOST NIL))
|
||||
[LET (TARGETHOST TARGETDEVICE PREFIXHOST)
|
||||
[LET (TARGETHOST TARGETDEVICE PREFIXHOST PHDEV)
|
||||
(CL:UNLESS [SETQ PREFIXHOST (U-CASE (FILENAMEFIELD PREFIX 'HOST]
|
||||
(SETQ PREFIX (UNSLASHIT (PACKFILENAME 'HOST (SETQ PREFIXHOST 'DSK)
|
||||
'BODY PREFIX))))
|
||||
@@ -120,26 +121,27 @@
|
||||
|
||||
(* ;; "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, unless a PHHOST preference is provided.")
|
||||
|
||||
(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)))
|
||||
(UNINTERRUPTABLY
|
||||
[change (fetch (TARGETDEVICE PREFIXMAPS) OF TARGETDEVICE)
|
||||
(SORT (CONS (LIST HOST PREFIX (CL:IF (EQ (CHARCODE /)
|
||||
(NTHCHARCODE PREFIX -1))
|
||||
'/
|
||||
'<))
|
||||
DATUM)
|
||||
(FUNCTION (LAMBDA (P1 P2)
|
||||
(IGREATERP (NCHARS (CADR P1))
|
||||
(NCHARS (CADR P2])]
|
||||
elseif (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)))
|
||||
(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)
|
||||
(CHANGE (fetch (TARGETDEVICE PREFIXMAPS) of TARGETDEV)
|
||||
(DREMOVE (ASSOC HOST DATUM)
|
||||
DATUM)))
|
||||
(SETQ \FILEDEVICES (DREMOVE PHHOST \FILEDEVICES))
|
||||
(\DEFINEDEVICE HOST NIL)))
|
||||
@@ -152,7 +154,8 @@
|
||||
HOST)])
|
||||
|
||||
(PSEUDOHOSTP
|
||||
[LAMBDA (HOST) (* ; "Edited 16-Dec-2024 21:15 by rmk")
|
||||
[LAMBDA (HOST) (* ; "Edited 27-Apr-2026 17:27 by rmk")
|
||||
(* ; "Edited 16-Dec-2024 21:15 by rmk")
|
||||
(* ; "Edited 24-Feb-2022 23:51 by rmk")
|
||||
(* ; "Edited 18-Jan-2022 11:29 by rmk")
|
||||
(LET [(DEV (if (type? FDEV HOST)
|
||||
@@ -161,9 +164,8 @@
|
||||
then (fetch (STREAM DEVICE) of HOST)
|
||||
else (\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)))])
|
||||
(LIST (fetch (FDEV DEVICENAME) of DEV)
|
||||
(fetch (PHDEVICE PREFIX) of DEV)))])
|
||||
|
||||
(PSEUDOHOSTS
|
||||
[LAMBDA NIL (* ; "Edited 17-Jan-2022 18:15 by rmk")
|
||||
@@ -218,7 +220,8 @@
|
||||
FILENAME))])
|
||||
|
||||
(PSEUDOFILENAME
|
||||
[LAMBDA (FILE PHOST) (* ; "Edited 26-Apr-2026 09:00 by rmk: If PHOST is non-NIL and a pseudohost, that's the one that the caller wants.")
|
||||
[LAMBDA (FILE PHOST) (* ; "Edited 27-Apr-2026 18:50 by rmk")
|
||||
(* ; "Edited 26-Apr-2026 09:00 by rmk: If PHOST is non-NIL and a pseudohost, that's the one that the caller wants.")
|
||||
(* ; "Edited 24-Apr-2026 22:52 by rmk")
|
||||
(* ; "Edited 26-Jul-2023 12:34 by rmk")
|
||||
(* ; "Edited 29-Jan-2022 23:08 by rmk")
|
||||
@@ -228,8 +231,21 @@
|
||||
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 PHOST)))
|
||||
do (RETURN PN) finally (RETURN FILENAME])
|
||||
when (type? PHDEVICE D) when (OR (NULL PHOST)
|
||||
(EQ PHOST (fetch (FDEV DEVICENAME) of D)))
|
||||
unless (EQ FILENAME (SETQ PN (CONTRACT.PH FILENAME D PHOST))) do (RETURN PN)
|
||||
finally (RETURN FILENAME])
|
||||
|
||||
(PSEUDOFILENAMES
|
||||
[LAMBDA (FILE) (* ; "Edited 27-Apr-2026 19:23 by rmk")
|
||||
(* ;
|
||||
"Edited 27-Apr-2026 10:00 by rmk; Edited 27-Apr-2026 09:33 by rmk")
|
||||
|
||||
(* ;; "Shows all the pseudohost synonyms for FILE (including its truename)")
|
||||
|
||||
(for D PN (TRUENAME _ (TRUEFILENAME FILE)) in \FILEDEVICES when (type? PHDEVICE D)
|
||||
unless [EQ TRUENAME (SETQ PN (PSEUDOFILENAME TRUENAME (fetch (FDEV DEVICENAME) of D]
|
||||
collect PN finally (RETURN (CONS TRUENAME $$VAL])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
@@ -261,57 +277,63 @@
|
||||
(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")
|
||||
(* ;; "Edited 27-Apr-2026 17:27 by rmk")
|
||||
|
||||
(* ;; "Edited 25-Apr-2022 09:35 by rmk: that FILENAME contains }, because HOST was identified in it. If FILENAME is a stream, expand to its true 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)
|
||||
[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)
|
||||
(CONCAT (fetch (PHDEVICE PREFIX) of PHDEV)
|
||||
SUFFIX)))
|
||||
ELSE FILENAME])
|
||||
else FILENAME])
|
||||
|
||||
(CONTRACT.PH
|
||||
[LAMBDA (NAME PHDEV PHOST)
|
||||
[LAMBDA (TRUENAME PHDEV PHOST)
|
||||
|
||||
(* ;; "Edited 27-Apr-2026 18:43 by rmk")
|
||||
|
||||
(* ;; "Edited 26-Apr-2026 10:31 by rmk")
|
||||
|
||||
(* ;; "Edited 22-Sep-2023 14:30 by rmk")
|
||||
|
||||
(* ;; "Finds the preferred pseudoname for NAME, the name on PHOST if given, else the shortest one. The PHDEV is used only to find its targetdev, that's where we scan for matching prefixes. This replaces the chosen prefix of NAME with the corresponding pseudohost.")
|
||||
(* ;; "Finds the preferred pseudoname for TRUENAME, the name on PHOST if given, else the shortest one. The PHDEV is used only to find its targetdev, that's where we scan for matching prefixes. This replaces the chosen prefix of TRUENAME with the corresponding pseudohost.")
|
||||
|
||||
(CL:WHEN NAME
|
||||
(CL:WHEN TRUENAME
|
||||
(CL:UNLESS (type? FDEV PHDEV)
|
||||
(SETQ PHDEV (\GETDEVICEFROMNAME PHDEV)))
|
||||
(CL:WHEN (EQ PHOST T)
|
||||
(SETQ PHOST (fetch (FDEV DEVICENAME) of PHDEV)))
|
||||
(LET ((PREFIXMAPS (fetch (TARGETDEVICE PREFIXMAP) of (fetch (PHDEVICE TARGETDEV) of PHDEV)))
|
||||
(LET ((PREFIXMAPS (fetch (TARGETDEVICE PREFIXMAPS) of (fetch (PHDEVICE TARGETDEV)
|
||||
of PHDEV)))
|
||||
PREFIXMNAP SUFFIX CONNECTOR)
|
||||
|
||||
(* ;; "PREFIXMAPs of PHDEVare sorted so that the longest one comes first.")
|
||||
(* ;;
|
||||
"PREFIXMAPs of PHDEVare sorted so that the longest one comes first, if PHOST isn't specified")
|
||||
|
||||
[SETQ PREFIXMAP (OR [AND PHOST (find PM in PREFIXMAPS suchthat (EQ PHOST (CADR PM]
|
||||
(find PM PREFIX in PREFIXMAPS
|
||||
suchthat (STRPOS (CAR PM)
|
||||
NAME 1 NIL T NIL FILEDIRCASEARRAY]
|
||||
(SETQ PREFIXMAP (find PM in PREFIXMAPS when (OR (NULL PHOST)
|
||||
(EQ PHOST (CAR PM)))
|
||||
suchthat (STRPOS (CADR PM)
|
||||
TRUENAME 1 NIL T NIL FILEDIRCASEARRAY)))
|
||||
|
||||
(* ;; "If we didn't find a prefix map, NAME was not related to any pseudohost 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.")
|
||||
(* ;; "If we didn't find a prefix map, TRUENAME was not related to any pseudohost 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.")
|
||||
|
||||
(if PREFIXMAP
|
||||
then (SETQ PREFIX (CAR PREFIXMAP))
|
||||
[SETQ SUFFIX (SUBSTRING NAME (ADD1 (NCHARS PREFIX]
|
||||
then (SETQ PREFIX (CADR PREFIXMAP))
|
||||
[SETQ SUFFIX (SUBSTRING TRUENAME (ADD1 (NCHARS PREFIX]
|
||||
(CL:WHEN (STRPOS ">" SUFFIX)
|
||||
|
||||
(* ;;
|
||||
@@ -321,10 +343,10 @@
|
||||
[SETQ SUFFIX (CONCAT CONNECTOR (CL:IF (EQ CONNECTOR '/)
|
||||
(SLASHIT SUFFIX)
|
||||
(UNSLASHIT SUFFIX))])
|
||||
(PACK* '{ (CADR PREFIXMAP)
|
||||
(PACK* '{ (CAR PREFIXMAP)
|
||||
"}"
|
||||
(OR SUFFIX ""))
|
||||
else NAME)))])
|
||||
else TRUENAME)))])
|
||||
|
||||
(UNSLASHIT
|
||||
[LAMBDA (X LCASEDIRS) (* ; "Edited 26-Jan-2022 15:09 by rmk")
|
||||
@@ -503,7 +525,7 @@
|
||||
|
||||
(RECORD PHGENFILESTATE (PHDEVICE . TARGETGENFILESTATE))
|
||||
|
||||
(ACCESSFNS TARGETDEVICE ((PREFIXMAP (FETCH (FDEV FDEV3) OF DATUM)
|
||||
(ACCESSFNS TARGETDEVICE ((PREFIXMAPS (FETCH (FDEV FDEV3) OF DATUM)
|
||||
(REPLACE (FDEV FDEV3) OF DATUM WITH NEWVALUE))))
|
||||
)
|
||||
|
||||
@@ -545,12 +567,12 @@
|
||||
)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1417 13360 (PSEUDOHOST 1427 . 7879) (PSEUDOHOSTP 7881 . 8710) (PSEUDOHOSTS 8712 . 9073)
|
||||
(TARGETHOST 9075 . 9944) (TRUEDEVICE 9946 . 10902) (TRUEFILENAME 10904 . 12191) (PSEUDOFILENAME 12193
|
||||
. 13358)) (13361 14400 (CDPSEUDO 13371 . 14398)) (14428 20089 (EXPAND.PH 14438 . 15691) (CONTRACT.PH
|
||||
15693 . 18005) (UNSLASHIT 18007 . 19753) (GETHOSTINFO.PH 19755 . 20087)) (20090 26711 (OPENFILE.PH
|
||||
20100 . 21225) (GETFILENAME.PH 21227 . 21625) (DIRECTORYNAMEP.PH 21627 . 22251) (CLOSEFILE.PH 22253 .
|
||||
22720) (REOPENFILE.PH 22722 . 23398) (DELETEFILE.PH 23400 . 23684) (GENERATEFILES.PH 23686 . 24880) (
|
||||
GETFILEINFO.PH 24882 . 25403) (SETFILEINFO.PH 25405 . 25714) (NEXTFILEFN.PH 25716 . 26432) (
|
||||
FILEINFOFN.PH 26434 . 26709)))))
|
||||
(FILEMAP (NIL (1275 14334 (PSEUDOHOST 1285 . 7847) (PSEUDOHOSTP 7849 . 8768) (PSEUDOHOSTS 8770 . 9131)
|
||||
(TARGETHOST 9133 . 10002) (TRUEDEVICE 10004 . 10960) (TRUEFILENAME 10962 . 12249) (PSEUDOFILENAME
|
||||
12251 . 13663) (PSEUDOFILENAMES 13665 . 14332)) (14335 15374 (CDPSEUDO 14345 . 15372)) (15402 21286 (
|
||||
EXPAND.PH 15412 . 16718) (CONTRACT.PH 16720 . 19202) (UNSLASHIT 19204 . 20950) (GETHOSTINFO.PH 20952
|
||||
. 21284)) (21287 27908 (OPENFILE.PH 21297 . 22422) (GETFILENAME.PH 22424 . 22822) (DIRECTORYNAMEP.PH
|
||||
22824 . 23448) (CLOSEFILE.PH 23450 . 23917) (REOPENFILE.PH 23919 . 24595) (DELETEFILE.PH 24597 . 24881
|
||||
) (GENERATEFILES.PH 24883 . 26077) (GETFILEINFO.PH 26079 . 26600) (SETFILEINFO.PH 26602 . 26911) (
|
||||
NEXTFILEFN.PH 26913 . 27629) (FILEINFOFN.PH 27631 . 27906)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Binary file not shown.
Reference in New Issue
Block a user