From 7df11afca95b99b7a93f6945d3e2ece79aa3733f Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Mon, 27 Apr 2026 22:06:48 -0700 Subject: [PATCH] SAMEDIR reworked/cleaned up, now accepts pseudohost equivalences --- library/SAMEDIR | 137 ++++++++++++++++++++++--------------------- library/SAMEDIR.LCOM | Bin 3800 -> 3295 bytes 2 files changed, 70 insertions(+), 67 deletions(-) diff --git a/library/SAMEDIR b/library/SAMEDIR index 1ff27939..1b1e67fa 100644 --- a/library/SAMEDIR +++ b/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}SAMEDIR.;4 6221 +(FILECREATED "27-Apr-2026 21:18:26" {WMEDLEY}SAMEDIR.;6 6540 - :CHANGES-TO (FNS CHECKSAMEDIR HOST&DIRECTORYFIELD) + :EDIT-BY rmk - :PREVIOUS-DATE "25-Apr-2022 09:23:16" {WMEDLEY}SAMEDIR.;3) + :CHANGES-TO (FNS CHECKSAMEDIR) + :PREVIOUS-DATE "31-Oct-2022 13:09:14" {MEDLEY}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 diff --git a/library/SAMEDIR.LCOM b/library/SAMEDIR.LCOM index 3185b143f600fd0225b5c02f279aed65aad4c6a7..32bfbbfe3c39c6f60941d71b71127287dd03f93b 100644 GIT binary patch delta 1656 zcmZuyO>7%g5cW?f%_d46leCRf!eomQJIaRrcf0~M8~ZuldcDuxUB^lj;iPqhEgDjV zNE|p=Lflchh#t6Af*VrOQXwJ0;>d{u2yp^&;#zSA%ItFz+^Bnap8xq~G&BD7<=-c+ zr3<8JIYcO0HW4hRNWrL@`Lek}fVUi8Kj~ z7#rVFV6N)YJRt=kZ+gU=gDOZec$Q%}wnzLM!m4T4NGO${fRYG@N|#;0FL_pl9Mfe4H!f~2#Ab1uP*Me0@%21>JVTwmR^ z{7|rnz^6J$WY+Mc0}3P4<4h8EQw(AvzL&9RJ`b@|jH&$?IGw{k9i$y}}}}XE>DK zJBp_2e0_!`USe;Vy_g<9X2^JFJ@|RR?L2&=m54SjMz5cV^KhJAj5Wr(H2L@?I@U@x zl8r={j>H-xM^7_!Y^IUy9{$y2PEYQ4&xffG`D6a$ZfpH;yr=u5hx0>b(H%_;Z-%Dz zbgIoz(E6*X(f9?LVg)CAK3@*d%gF~v|NhiUFhPsGB~~A^+h{)gv&7o)=(jr;dRi9F z4yMk{6z+8oKkr4l-%ERV^7~OFt%)jlC0er!jt^>12jaTaodz|lfa#TM9&tg{7EOdC|38@vQKOgMWup5Z+RIS035p=Sw77XABHg>3;S zs`ftsMaco)kE&~df>DmK$hsIN?o>!+8R5us?i8Ag@blEkn?8=Dd`fD$Qxe0V@3Cu6 z1sr~o_o=%ULW9LDY?#$5aSAeEma0c;1$qM915IV?GsB#MPhaGMrSn%i>S7KY>`)HY zKvlD_N?gyPC{eUfB5JTq3u~a{a;GWTui@q;2Nm`2vH zKmDziH#EFRKJk2zSwab`a&SduOfDfD3X+Ih-0vfa(y@!KL&aKgO&pa3ZFv!QX>IT+x+ao|_(%6-YajR_;Mca_orm}K+WXtk-iOxq-ZqcdCL8?1&Bk!R fo^q*}q6d>hlQBgM7Kb1vtB-CDU5XDlmd*VK0A7iJ literal 3800 zcmb_fU2h{-8Fn18P`A6?6oF7KmbW9=j-xuvr@ugSC*yHE&3KM8Gfv1#sP)DJw%GMV zjI}+&#Ab6o6)_VWgl6G4oR*bIf3VfJ&EoGj@62+1Mj8l11oe$Rm!E3%sJRVi<}lo zx>{l9vx=r@8mW3yX*4xOB3U|5o?MI{$3sdcB+*Y#yH3k<&VKg2$KyxS!Sw3;p@kba z*#E9krjn#9D=v!CRO(H&Av%01 zLteY@d6eh5zrQb0X*ifcp$)<`T`K=qyHw+5JE*E@DmCqnC1NDE{cv63(guyo z)a(V$iOc$7r3I&wq?r}#Vw(DtJ5+C~)f;8&Nnx#iw|iD;v!Eid_NYyo@a=ctTO4$O=6j(N9al~)ukVzp@Xcbe zSQtOpDQ*SNUl|We1^iy&%V_uf){pt-Zb4QXWc!?nY7h@Bcv-7c(`P}~@^Dz!d#SQP zdo}}I{H3`4AU)B!@v<+ z7z)@1$nLxU0a6@p|6%y6(eCbFIy-8K-PwM={quR@cjGrcnQvLAbowo!-~+L~D^}p* zCuE9qXRDZMB!Ui5al3*Gpt#FZW5B1rlE-h;F%#R_I?-z$ZIlHjcl*k4Bc)IEh@dOILCdV;0f z#WJqAN^|?={-Rffni-){r6}mbl2jSe4RvE%(sea254pdg6`*J7na?z+l=)0EA(Q#2 z&ZOzea;wx<+s#r{rSY;|b$wl7bF(Iun-Fhy!5bd@}%XM@R%W(hqR{3NE? zD5f7_zM{e8>e=8*LR!^G8VxS#ay&W5^~FUzn8w30<{lHFCyg&@l7Jp`Pm;?SVYG_D z?}K=HImU=4FE&z%46{lyQbXh}?dP6n(TU5X)l`yw=GYz9_6{k+4IV+3G5Z9TjSK?= zY;D$Z$YEZ&3*U!RjwSKXEgXAp1d`q$H`#G$KI*nIEyFTr6eP=4}EAWrXfrk z=@?ZmZ<+|xIVhVHc=na4aDXzrC2H@3Rk0S;{eQZ=eT&y|jASUqo2n-pl2N)=kE|uUzoi&)Y~%2uJ1-C7N$HoKXu_lXL*s$R3-Vi&oG`d z9?r7W!V_|`ERw|lM>0d~r?V!{f!wzW_Y5b59en(z1-FbGOaUydY5_kUdhEdRgq%EJ zVevbe#bQw8-)6!Q%j-<>mEI+;cErGNnSlQXwewt;g%Qg1`VpeO7iMarS@q5W_plS; z`|u>5JdNo-{UDwuACjF+FOunChEjx-YSi&9*{BEEXdhS~rC