UNPACKFILENAME produces lt-gt for top-level directory (#1696)
* UNPACKFILENAME produces <> for top-level directory For virtually any combination of leading <, > or /. Addresses #1685. * Produce < instead of <> for top-level empty directory Does not yet deal with all combinations of directory-internal bracket sequences
This commit is contained in:
rmkaplan
GitHub
parent
b8de8209d0
commit
8e22a4dcb9
98
sources/ADIR
98
sources/ADIR
@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 9-Mar-2024 10:24:39" {WMEDLEY}<sources>ADIR.;38 67777
|
||||
(FILECREATED " 6-May-2024 15:54:01" {WMEDLEY}<sources>ADIR.;45 67756
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS UNPACKFILENAME.STRING FILENAMEFIELD FILENAMEFIELD.STRING \UPF.DIRECTORY)
|
||||
:CHANGES-TO (FNS \UPF.DIRECTORY)
|
||||
|
||||
:PREVIOUS-DATE "13-Nov-2023 20:28:57" {WMEDLEY}<sources>ADIR.;31)
|
||||
:PREVIOUS-DATE " 4-May-2024 16:25:09" {WMEDLEY}<sources>ADIR.;44)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT ADIRCOMS)
|
||||
@ -317,7 +317,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(UNPACKFILENAME.STRING
|
||||
[LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG) (* ; "Edited 9-Mar-2024 10:23 by rmk")
|
||||
[LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG) (* ; "Edited 4-May-2024 12:45 by rmk")
|
||||
(* ; "Edited 9-Mar-2024 10:23 by rmk")
|
||||
(* ; "Edited 13-Nov-2023 20:28 by rmk")
|
||||
(* ; "Edited 28-Apr-2022 11:40 by rmk")
|
||||
(* ; "Edited 24-Apr-2022 14:11 by rmk")
|
||||
@ -350,7 +351,6 @@
|
||||
(* ;; "")
|
||||
|
||||
(* ;; " If there is at least one / or > then the last one ends the directory, anything before is possibly a relative or subdirectory. Anything after is a name")
|
||||
(* ; "")
|
||||
|
||||
(* ;; " (Rationale: Those are not sub-directory brackets)")
|
||||
|
||||
@ -662,52 +662,48 @@
|
||||
(PUSH $$VAL F FVAL])
|
||||
|
||||
(\UPF.DIRECTORY
|
||||
[LAMBDA (DIRSTART DIREND DIRDIRTY $$BASE $$FATP $$READONLY)(* ; "Edited 8-Mar-2024 23:03 by rmk")
|
||||
[LAMBDA (DIRSTART DIREND DIRDIRTY $$BASE $$FATP $$READONLY)(* ; "Edited 6-May-2024 15:53 by rmk")
|
||||
(* ; "Edited 4-May-2024 16:25 by rmk")
|
||||
(* ; "Edited 8-Mar-2024 23:03 by rmk")
|
||||
(* ; "Edited 28-Apr-2022 09:15 by rmk")
|
||||
(* ; "Edited 27-Apr-2022 08:50 by rmk")
|
||||
(* ; "Edited 23-Apr-2022 17:09 by rmk")
|
||||
|
||||
(* ;; "Relative directory {abc}<foo or {abc}< with no >, subdirectory >foo or > with no host or device (DIRSTART=1). ")
|
||||
(* ;; "Extract the directory field, producing <> for the empty (top-level) directory, normalizing / to < or >.")
|
||||
|
||||
(* ;; "Advance DIRSTART through initial duplicates")
|
||||
(if (ILEQ DIREND DIRSTART)
|
||||
then
|
||||
(* ;; "An empty directory field is interpreted as the top as per issue #1685: <xy >xy /xy all map to <>")
|
||||
|
||||
(LET ((BRACKET (SELCHARQ (\GETBASECHAR $$FATP $$BASE DIRSTART)
|
||||
((< /)
|
||||
"<")
|
||||
(> ">")
|
||||
NIL)))
|
||||
(IF (EQ DIREND DIRSTART)
|
||||
THEN
|
||||
(* ;; "If EQ, the directory is is empty.")
|
||||
(MKSTRING "<")
|
||||
else (CL:WHEN (MEMB (\GETBASECHAR $$FATP $$BASE DIRSTART)
|
||||
(CHARCODE (< / >))) (* ; "Skip leading brackets")
|
||||
(ADD DIRSTART 1))
|
||||
|
||||
(MKSTRING "")
|
||||
ELSE (CL:WHEN BRACKET (* ; "Skip the < or /")
|
||||
(ADD DIRSTART 1))
|
||||
(* ;;
|
||||
"If DIRDIRTY, the string contained at least one / that has to be converted to < or >")
|
||||
|
||||
(* ;;
|
||||
"Convert / to >, remove all // /> >> duplicate sequences (keep the first, skip the others)")
|
||||
(IF DIRDIRTY
|
||||
THEN (FOR DIROFF C DEST DESTBASE (DESTPOS _ -1) FROM DIRSTART TO DIREND
|
||||
FIRST (SETQ DEST (ALLOCSTRING (ADD1 (IDIFFERENCE DIREND DIRSTART))
|
||||
NIL NIL $$FATP))
|
||||
(SETQ DESTBASE (FETCH (STRINGP BASE) OF DEST))
|
||||
DO (ADD DESTPOS 1)
|
||||
(SETQ C (\GETBASECHAR $$FATP $$BASE DIROFF))
|
||||
(SELCHARQ C
|
||||
((> /)
|
||||
(\PUTBASECHAR $$FATP DESTBASE DESTPOS (CHARCODE >))
|
||||
|
||||
(IF DIRDIRTY
|
||||
THEN (FOR DIROFF C DEST DESTBASE (DESTPOS _ -1) FROM DIRSTART TO DIREND
|
||||
FIRST (SETQ DEST (ALLOCSTRING (ADD1 (IDIFFERENCE DIREND DIRSTART))
|
||||
NIL NIL $$FATP))
|
||||
(SETQ DESTBASE (FETCH (STRINGP BASE) OF DEST))
|
||||
DO (ADD DESTPOS 1)
|
||||
(SETQ C (\GETBASECHAR $$FATP $$BASE DIROFF))
|
||||
(SELCHARQ C
|
||||
((> /)
|
||||
(\PUTBASECHAR $$FATP DESTBASE DESTPOS (CHARCODE >))
|
||||
(* ;; "Advance past duplicates")
|
||||
|
||||
(* ;; "Advance past duplicates")
|
||||
|
||||
(FIND I FROM (ADD1 DIROFF) TO DIREND
|
||||
WHILE (FMEMB (\GETBASECHAR $$FATP $$BASE I)
|
||||
(CHARCODE (> /)))
|
||||
FINALLY (SETQ DIROFF (SUB1 I))))
|
||||
(\PUTBASECHAR $$FATP DESTBASE DESTPOS C))
|
||||
FINALLY (REPLACE (STRINGP LENGTH) OF DEST WITH DESTPOS)
|
||||
(RETURN DEST))
|
||||
ELSE (\UPF.EXTRACT DIRSTART (SUB1 DIREND])
|
||||
(FIND I FROM (ADD1 DIROFF) TO DIREND
|
||||
WHILE (FMEMB (\GETBASECHAR $$FATP $$BASE I)
|
||||
(CHARCODE (> /))) FINALLY (SETQ DIROFF
|
||||
(SUB1 I))))
|
||||
(\PUTBASECHAR $$FATP DESTBASE DESTPOS C))
|
||||
FINALLY (REPLACE (STRINGP LENGTH) OF DEST WITH DESTPOS)
|
||||
(RETURN DEST))
|
||||
ELSE (\UPF.EXTRACT DIRSTART (SUB1 DIREND])
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
@ -1254,14 +1250,14 @@
|
||||
(ADDTOVAR LAMA PACKFILENAME.STRING PACKFILENAME)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3169 15826 (DELFILE 3179 . 3340) (FULLNAME 3342 . 3709) (INFILE 3711 . 3970) (INFILEP
|
||||
3972 . 4107) (IOFILE 4109 . 4360) (OPENFILE 4362 . 4665) (OPENSTREAM 4667 . 9007) (OUTFILE 9009 . 9271
|
||||
) (OUTFILEP 9273 . 9409) (RENAMEFILE 9411 . 9717) (SIMPLE.FINDFILE 9719 . 10129) (VMEMSIZE 10131 .
|
||||
10298) (\COPYSYS 10300 . 14545) (\FLUSHVM 14547 . 15619) (\LOGOUT0 15621 . 15824)) (16284 38972 (
|
||||
UNPACKFILENAME.STRING 16294 . 36274) (\UPF.DIRECTORY 36276 . 38970)) (40500 42806 (UNPACKFILENAME
|
||||
40510 . 40696) (LASTCHPOS 40698 . 41392) (FILENAMEFIELD 41394 . 41688) (FILENAMEFIELD.STRING 41690 .
|
||||
42094) (PACKFILENAME 42096 . 42439) (PACKFILENAME.STRING 42441 . 42804)) (57276 58189 (
|
||||
FILEDIRCASEARRAY 57286 . 58187)) (58356 65536 (LOGOUT 58366 . 59283) (MAKESYS 59285 . 60914) (SYSOUT
|
||||
60916 . 62468) (SAVEVM 62470 . 63270) (HERALD 63272 . 63432) (INTERPRET.REM.CM 63434 . 65159) (
|
||||
\USEREVENT 65161 . 65534)) (65718 67445 (USERNAME 65728 . 66684) (SETUSERNAME 66686 . 67443)))))
|
||||
(FILEMAP (NIL (3112 15769 (DELFILE 3122 . 3283) (FULLNAME 3285 . 3652) (INFILE 3654 . 3913) (INFILEP
|
||||
3915 . 4050) (IOFILE 4052 . 4303) (OPENFILE 4305 . 4608) (OPENSTREAM 4610 . 8950) (OUTFILE 8952 . 9214
|
||||
) (OUTFILEP 9216 . 9352) (RENAMEFILE 9354 . 9660) (SIMPLE.FINDFILE 9662 . 10072) (VMEMSIZE 10074 .
|
||||
10241) (\COPYSYS 10243 . 14488) (\FLUSHVM 14490 . 15562) (\LOGOUT0 15564 . 15767)) (16227 38951 (
|
||||
UNPACKFILENAME.STRING 16237 . 36252) (\UPF.DIRECTORY 36254 . 38949)) (40479 42785 (UNPACKFILENAME
|
||||
40489 . 40675) (LASTCHPOS 40677 . 41371) (FILENAMEFIELD 41373 . 41667) (FILENAMEFIELD.STRING 41669 .
|
||||
42073) (PACKFILENAME 42075 . 42418) (PACKFILENAME.STRING 42420 . 42783)) (57255 58168 (
|
||||
FILEDIRCASEARRAY 57265 . 58166)) (58335 65515 (LOGOUT 58345 . 59262) (MAKESYS 59264 . 60893) (SYSOUT
|
||||
60895 . 62447) (SAVEVM 62449 . 63249) (HERALD 63251 . 63411) (INTERPRET.REM.CM 63413 . 65138) (
|
||||
\USEREVENT 65140 . 65513)) (65697 67424 (USERNAME 65707 . 66663) (SETUSERNAME 66665 . 67422)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Loading…
x
Reference in New Issue
Block a user