SAMEDIR reworked/cleaned up, now accepts pseudohost equivalences
This commit is contained in:
rmkaplan
137
library/SAMEDIR
137
library/SAMEDIR
@@ -1,15 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
|
||||
|
||||
(FILECREATED "31-Oct-2022 13:09:14" {WMEDLEY}<library>SAMEDIR.;4 6221
|
||||
(FILECREATED "27-Apr-2026 21:18:26" {WMEDLEY}<library>SAMEDIR.;6 6540
|
||||
|
||||
:CHANGES-TO (FNS CHECKSAMEDIR HOST&DIRECTORYFIELD)
|
||||
:EDIT-BY rmk
|
||||
|
||||
:PREVIOUS-DATE "25-Apr-2022 09:23:16" {WMEDLEY}<library>SAMEDIR.;3)
|
||||
:CHANGES-TO (FNS CHECKSAMEDIR)
|
||||
|
||||
:PREVIOUS-DATE "31-Oct-2022 13:09:14" {MEDLEY}<library>SAMEDIR.;4)
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1982, 1984-1987, 1990, 2018, 2020 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT SAMEDIRCOMS)
|
||||
|
||||
@@ -24,7 +22,8 @@ Copyright (c) 1982, 1984-1987, 1990, 2018, 2020 by Venue & Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(CHECKSAMEDIR
|
||||
[LAMBDA (FILE) (* ; "Edited 31-Oct-2022 13:08 by rmk")
|
||||
[LAMBDA (FILE) (* ; "Edited 27-Apr-2026 21:18 by rmk")
|
||||
(* ; "Edited 31-Oct-2022 13:08 by rmk")
|
||||
(* ; "Edited 25-Apr-2022 09:16 by rmk")
|
||||
(* ; "Edited 1-Sep-2020 11:40 by rmk:")
|
||||
|
||||
@@ -32,70 +31,75 @@ Copyright (c) 1982, 1984-1987, 1990, 2018, 2020 by Venue & Xerox Corporation.
|
||||
|
||||
(* ;; " OKHOST/DIRS is a list of places it's OK for the file to be winding up, so if your'e migrating code from one place ot another, you can do it gracefully.")
|
||||
|
||||
(* ;;
|
||||
"MIGRATIONS may be provided as a global variable, to suppress the askusers. See documentation. ")
|
||||
|
||||
[RESETSAVE (DIRECTORYNAME T)
|
||||
'(PROGN (CNDIR OLDVALUE] (* ;
|
||||
'(PROGN (CNDIR OLDVALUE]
|
||||
(SETQ FILE (ROOTFILENAME FILE)) (* ;
|
||||
"Assumes that MAKEFILE has RESETLST")
|
||||
(PROG ((*UPPER-CASE-FILE-NAMES* NIL)
|
||||
(DATES (GET (SETQ FILE (ROOTFILENAME FILE))
|
||||
'FILEDATES))
|
||||
HOST/DIR HOST DIR NEWV OKHOST/DIRS)
|
||||
[OLDFILE (CDAR (LISTP (GET FILE 'FILEDATES]
|
||||
PREVPDIRS HOST/DIR NEWV OKHOST/DIRS OLDDIR)
|
||||
(CL:UNLESS OLDFILE (RETURN))
|
||||
|
||||
(* ;; "Only the first previor location matters. If we moved it, we don't want to move it back.")
|
||||
|
||||
(SETQ OLDDIR (HOST&DIRECTORYFIELD OLDFILE))
|
||||
|
||||
(* ;; "PREVPDIRS is a list of all possible pseudohost synonyms for the previous location of FILE. Use HOST&DIRECTORYFIELD to canonicalize both file and connected directory")
|
||||
|
||||
(SETQ PREVPDIRS (PSEUDOFILENAMES OLDDIR)) (* ;
|
||||
"Any pseudohost or migrating pseudohost is good")
|
||||
(SETQ OKHOST/DIRS (APPEND (for M in MIGRATIONS when (CL:MEMBER (CAR M)
|
||||
PREVPDIRS :TEST
|
||||
(FUNCTION STRING-EQUAL))
|
||||
collect (CDR M))
|
||||
PREVPDIRS))
|
||||
AGAIN
|
||||
(OR (LISTP DATES)
|
||||
(RETURN)) (* ;
|
||||
"RMK: Use HOST&DIRECTORYFIELD to canonicalize both file and connected directory")
|
||||
[SETQ OKHOST/DIRS (CONS (SETQ HOST/DIR (HOST&DIRECTORYFIELD (DIRECTORYNAME T)))
|
||||
(MKLIST (CDR (OR (ASSOC HOST/DIR MIGRATIONS :TEST 'STRING-EQUAL)
|
||||
(ASSOC (TRUEFILENAME HOST/DIR)
|
||||
MIGRATIONS :TEST 'STRING-EQUAL)
|
||||
(ASSOC (PSEUDOFILENAME HOST/DIR)
|
||||
MIGRATIONS :TEST 'STRING-EQUAL]
|
||||
(COND
|
||||
([for OLDFILE in DATES bind HOST DIR
|
||||
never (OR (CL:MEMBER (HOST&DIRECTORYFIELD (CDR OLDFILE))
|
||||
OKHOST/DIRS :TEST 'STRING-EQUAL)
|
||||
(CL:MEMBER (TRUEFILENAME (HOST&DIRECTORYFIELD (CDR OLDFILE)))
|
||||
OKHOST/DIRS :TEST 'STRING-EQUAL)
|
||||
(CL:MEMBER (PSEUDOFILENAME (HOST&DIRECTORYFIELD (CDR OLDFILE)))
|
||||
OKHOST/DIRS :TEST 'STRING-EQUAL]
|
||||
(* ; "Come here on new directory")
|
||||
(SETQ HOST/DIR (DIRECTORYNAME T)) (* ;
|
||||
"Current directory, maybe newly connected")
|
||||
(if (NOT (CL:MEMBER HOST/DIR OKHOST/DIRS :TEST (FUNCTION STRING-EQUAL)))
|
||||
then
|
||||
(* ;; "The file would go somewhere new. Is that what the user really wants?")
|
||||
|
||||
(* ;; "The file is going somewhere it has never been before. ")
|
||||
(SELECTQ (ASKUSER SAMEDIRWAIT SAMEDIRDEFAULT (LIST "You haven't loaded or written"
|
||||
FILE
|
||||
"in your connected directory"
|
||||
HOST/DIR
|
||||
"-- write it out anyway")
|
||||
`[[O ,(CONCAT "Oops! Make file on " (SETQ HOST/DIR OLDDIR]
|
||||
(C "Make file on other directory: ")
|
||||
(Y ,(CONCAT "Yes, write it here")
|
||||
(CHARACTER (CHARCODE EOL)))
|
||||
(N ,(CONCAT "No, abort MAKEFILE")
|
||||
(CHARACTER (CHARCODE EOL]
|
||||
NIL NIL '(NOECHOFLG T))
|
||||
(Y (RETURN))
|
||||
(N (ERROR!))
|
||||
(C (SETQ HOST/DIR NIL))
|
||||
(O (* ;
|
||||
"Choose DATE directory above, switch in NLSETQ below, switch back in RESETSAVE above")
|
||||
(TERPRI T))
|
||||
(SHOULDNT))
|
||||
(CL:WHEN [NLSETQ (CNDIR (OR HOST/DIR (READ T T]
|
||||
(RETURN))
|
||||
(GO AGAIN)
|
||||
elseif (AND (SETQ NEWV (INFILEP (PACKFILENAME.STRING 'VERSION NIL 'BODY OLDFILE)))
|
||||
(NOT (STRING-EQUAL NEWV OLDFILE)))
|
||||
then
|
||||
(* ;; "A newer version appeared while the user was editing this file.")
|
||||
|
||||
(* ;; "Check that that is really what the user wants.")
|
||||
(* ;; "Ask if he should over-write it.")
|
||||
|
||||
(SELECTQ (ASKUSER SAMEDIRWAIT SAMEDIRDEFAULT (LIST "You haven't loaded or written" FILE
|
||||
"in your connected directory"
|
||||
HOST/DIR "-- write it out anyway")
|
||||
`[[O ,(CONCAT "Oops! Make file on " (SETQ HOST/DIR (
|
||||
HOST&DIRECTORYFIELD
|
||||
(CDAR DATES]
|
||||
(C "Make file on other directory: ")
|
||||
(Y ,(CONCAT "Yes, write it here")
|
||||
(CHARACTER (CHARCODE EOL)))
|
||||
(N ,(CONCAT "No, abort MAKEFILE")
|
||||
(CHARACTER (CHARCODE EOL]
|
||||
NIL NIL '(NOECHOFLG T))
|
||||
(Y (RETURN))
|
||||
(N (ERROR!))
|
||||
(C (SETQ HOST/DIR))
|
||||
(O (TERPRI T))
|
||||
(SHOULDNT))
|
||||
[NLSETQ (CNDIR (OR HOST/DIR (READ T T]
|
||||
(GO AGAIN))
|
||||
([AND [SETQ NEWV (INFILEP (PACKFILENAME.STRING 'VERSION NIL 'BODY (CDAR DATES]
|
||||
(NOT (STRING-EQUAL NEWV (CDAR DATES]
|
||||
|
||||
(* ;; "A newer version appeared while the user was editing this file.")
|
||||
|
||||
(* ;; "Ask if he should over-write it.")
|
||||
|
||||
(SELECTQ (ASKUSER 15 'Y (LIST (CDAR DATES)
|
||||
"is not the most recent version (version"
|
||||
(FILENAMEFIELD.STRING NEWV 'VERSION)
|
||||
"has since appeared)."
|
||||
"Do you want to make the file anyway"))
|
||||
(Y)
|
||||
(N (ERROR!))
|
||||
(SHOULDNT])
|
||||
(SELECTQ (ASKUSER 15 'Y (LIST OLDFILE "is not the most recent version (version"
|
||||
(FILENAMEFIELD.STRING NEWV 'VERSION)
|
||||
"has since appeared)."
|
||||
"Do you want to make the file anyway"))
|
||||
(Y)
|
||||
(N (ERROR!))
|
||||
(SHOULDNT])
|
||||
|
||||
(HOST&DIRECTORYFIELD
|
||||
[LAMBDA (FILENAME) (* ; "Edited 31-Oct-2022 13:03 by rmk")
|
||||
@@ -120,7 +124,6 @@ Copyright (c) 1982, 1984-1987, 1990, 2018, 2020 by Venue & Xerox Corporation.
|
||||
|
||||
(GLOBALVARS MIGRATIONS)
|
||||
)
|
||||
(PUTPROPS SAMEDIR COPYRIGHT ("Venue & Xerox Corporation" 1982 1984 1985 1986 1987 1990 2018 2020))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (731 5838 (CHECKSAMEDIR 741 . 5249) (HOST&DIRECTORYFIELD 5251 . 5836)))))
|
||||
(FILEMAP (NIL (641 6256 (CHECKSAMEDIR 651 . 5667) (HOST&DIRECTORYFIELD 5669 . 6254)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user