[Mit-cadr-cvs] r378 - in trunk: emulator/usim lisp/io
ggilley at common-lisp.net
ggilley at common-lisp.net
Sat Dec 1 00:31:05 UTC 2012
Author: ggilley
Date: Fri Nov 30 16:31:05 2012
New Revision: 378
Log:
progress toward dired working properly
Modified:
trunk/emulator/usim/Files.c
trunk/emulator/usim/glob.c
trunk/lisp/io/pathnm.lisp
Modified: trunk/emulator/usim/Files.c
==============================================================================
--- trunk/emulator/usim/Files.c Thu Nov 29 23:02:40 2012 (r377)
+++ trunk/emulator/usim/Files.c Fri Nov 30 16:31:05 2012 (r378)
@@ -2254,35 +2254,14 @@
struct stat *s = (struct stat *)0;
struct stat sbuf;
int errcode;
- char *wild;
- size_t len = strlen(x->x_realname);
- //printf("diropen: %s -> ", x->x_realname);
-
- // lisp keeps appending .wild
- for (wild=x->x_realname; *wild; wild++, len--)
- if (*wild == 'w' && len > 3)
- {
- if (*(wild + 1) == 'i' && *(wild + 2) == 'l' && *(wild + 3) == 'd')
- {
- *wild = '\0';
- while (wild != x->x_realname && *(wild - 1) == '.')
- {
- *(wild - 1) = '\0';
- wild--;
- }
- }
- }
-
- if (x->x_realname[strlen(x->x_realname)-1] == '/')
- x->x_realname[strlen(x->x_realname)-1] = '\0';
-
-// printf("%s\n", x->x_realname);
+// printf("diropen: %s\n", x->x_realname);
x->x_glob = glob(x->x_realname);
if ((errcode = globerr) != 0)
goto derror;
- if (x->x_glob) {
+
+ if (x->x_glob) {
char **badfile = NOBLK;
int baderrno;
/*
Modified: trunk/emulator/usim/glob.c
==============================================================================
--- trunk/emulator/usim/glob.c Thu Nov 29 23:02:40 2012 (r377)
+++ trunk/emulator/usim/glob.c Fri Nov 30 16:31:05 2012 (r378)
@@ -79,18 +79,50 @@
{
char agpath[BUFSIZ];
char *vv[2];
+
vv[0] = v;
vv[1] = 0;
gflag = 0;
rscan(vv, tglob);
if (gflag == 0)
- return copyblk(vv);
+ {
+#if 0 // if you do a change properties on a directory, it wants the directory
+ struct stat sbuf;
+
+ // if it's a directory, we're probably looking for the list of contents
+ if (stat(v, &sbuf) == 0) {
+ if ((sbuf.st_mode & S_IFMT) == S_IFDIR)
+ {
+ ssize_t len = strlen(v);
+
+ wild = malloc(len + 3);
+ strcpy(wild, v);
+ if (wild[len] != '/')
+ wild[len++] = '/';
+ wild[len++] = '*';
+ wild[len] = '\0';
+
+ vv[0] = wild;
+ vv[1] = 0;
+ rscan(vv, tglob);
+ if (gflag == 0)
+ {
+ free(wild);
+ vv[0] = v;
+ return copyblk(vv);
+ }
+ }
+ }
+ else
+#endif
+ return copyblk(vv);
+ }
globerr = 0;
gpath = agpath; gpathp = gpath; *gpathp = 0;
lastgpathp = &gpath[sizeof agpath - 2];
ginit(); globcnt = 0;
- collect(v);
+ collect(vv[0]);
if (globcnt == 0 && (gflag&1)) {
blkfree(gargv), gargv = 0;
lastgpathp = 0;
@@ -101,12 +133,12 @@
lastgpathp = 0;
gpathp = 0;
gpath = 0;
- return (gargv = copyblk(gargv));
+ return gargv;
}
void gfree(char **glob)
{
- free(glob);
+ blkfree(glob);
}
static void
@@ -713,12 +745,31 @@
char **
copyblk(register char **v)
{
+ if (v == 0)
+ return 0;
+
register char **nv = (char **)malloc((size_t)(((size_t)blklen(v) + 1) *
sizeof(char **)));
if (nv == (char **)0)
fatal(NOMEM);
- return (blkcpy(nv, v));
+ register char **av = v;
+
+ if (av)
+ {
+ char **bv = nv;
+
+ while (*av)
+ {
+ *bv = malloc(strlen(*av) + 1);
+ strcpy(*bv, *av);
+ av++;
+ bv++;
+ }
+ *bv = 0;
+ }
+
+ return nv;
}
static
Modified: trunk/lisp/io/pathnm.lisp
==============================================================================
--- trunk/lisp/io/pathnm.lisp Thu Nov 29 23:02:40 2012 (r377)
+++ trunk/lisp/io/pathnm.lisp Fri Nov 30 16:31:05 2012 (r378)
@@ -1409,21 +1409,32 @@
(DEFMETHOD (UNIX-PATHNAME-MIXIN :DIRECTORY-UP-DELIMITER) () "..")
+(DEFUN UNIX-FILENAME (NAME TYPE &AUX (NEW-TYPE (IF TYPE TYPE "'")))
+ (IF (EQ NAME ':UNSPECIFIC) (SETQ NAME ""))
+ (IF (EQ NAME ':WILD)
+ (IF (MEMQ TYPE '(:WILD :UNSPECIFIC))
+ "*" ;Both wild, just *
+ (STRING-APPEND "*." NEW-TYPE))
+ (IF (AND (NULL NAME) (MEMQ TYPE '(NIL :UNSPECIFIC)))
+ ""
+ (OR NAME (SETQ NAME "'"))
+ (COND ((EQ TYPE ':WILD)
+ (FORMAT NIL "~A.*" NAME))
+ ((EQ TYPE ':UNSPECIFIC)
+ NAME)
+ (T
+ (STRING-APPEND NAME "." NEW-TYPE))))))
+
(DEFMETHOD (UNIX-PATHNAME-MIXIN :STRING-FOR-HOST) ()
- (FORMAT NIL "~@[~A~]~:[~A~;~*~]~:[.~A~;~*~]"
- (UNIX-DIRECTORY-STRING)
- (MEMQ NAME '(NIL :UNSPECIFIC)) NAME
- (MEMQ TYPE '(NIL :UNSPECIFIC)) TYPE))
+ (FORMAT NIL "~@[~A~]~A" (UNIX-DIRECTORY-STRING) (UNIX-FILENAME NAME TYPE)))
(DEFMETHOD (UNIX-PATHNAME-MIXIN :STRING-FOR-EDITOR) ()
- (FORMAT NIL "~A~:[.~A~;~*~] ~A ~A:"
- NAME (MEMQ TYPE '(NIL :UNSPECIFIC)) TYPE
- (UNIX-DIRECTORY-STRING)
- (FUNCALL HOST ':NAME-AS-FILE-COMPUTER)))
+ (FORMAT NIL "~A ~A ~A:"
+ (UNIX-FILENAME NAME TYPE) (UNIX-DIRECTORY-STRING)
+ (FUNCALL HOST ':NAME-AS-FILE-COMPUTER)))
(DEFMETHOD (UNIX-PATHNAME-MIXIN :STRING-FOR-DIRED) ()
- (FORMAT NIL "~A~:[.~A~;~*~]"
- NAME (MEMQ TYPE '(NIL :UNSPECIFIC)) TYPE))
+ (UNIX-FILENAME NAME TYPE))
(DECLARE-FLAVOR-INSTANCE-VARIABLES (UNIX-PATHNAME-MIXIN)
(DEFUN UNIX-DIRECTORY-STRING ()
@@ -1468,48 +1479,89 @@
(OTHERWISE (STRING STRING))))
(DEFMETHOD (UNIX-PATHNAME-MIXIN :PARSE-NAMESTRING) (IGNORE NAMESTRING
- &OPTIONAL (START 0) END
- &AUX DIR NAME TYPE DELIM-CHAR)
+ &OPTIONAL (START 0) END
+ &AUX DIR NAM TYP (VER ':UNSPECIFIC)
+ DELIM-CHAR DIRSTART DIREND)
(OR END (SETQ END (STRING-LENGTH NAMESTRING)))
(SETQ START (OR (STRING-SEARCH-NOT-CHAR #\SP NAMESTRING START END) END))
- (SETQ DELIM-CHAR (FUNCALL-SELF ':DIRECTORY-DELIMITER-CHARACTER)
- DIR (STRING-REVERSE-SEARCH-CHAR DELIM-CHAR NAMESTRING END START)
- TYPE (STRING-REVERSE-SEARCH-CHAR #/. NAMESTRING END (OR DIR START)))
- (COND (DIR
- (PSETQ START (1+ DIR)
- DIR (LET ((RELATIVE-P T)
- (DIR-START START)
- (UP (FUNCALL-SELF ':DIRECTORY-UP-DELIMITER))
- (NUP NIL)
- (STRS NIL))
- (COND ((= (AREF NAMESTRING DIR-START) DELIM-CHAR)
- (SETQ RELATIVE-P NIL)
- (INCF DIR-START))
- ((NUMBERP UP)
- (SETQ NUP (LOOP WHILE (= (AREF NAMESTRING DIR-START) UP)
- COLLECT ':UP
- DO (INCF DIR-START)))))
- (AND (> DIR START)
- (SETQ STRS (LOOP FOR IDX = DIR-START THEN (1+ JDX)
- AS JDX = (STRING-SEARCH-CHAR DELIM-CHAR
- NAMESTRING IDX DIR)
- COLLECT (SUBSTRING NAMESTRING IDX (OR JDX DIR))
- WHILE JDX)))
- (AND (STRINGP UP)
- (DO L STRS (CDR L) (NULL L)
- (AND (STRING-EQUAL (CAR L) UP)
- (RPLACA L ':UP))))
- (AND NUP (SETQ STRS (NCONC NUP STRS)))
- (COND (RELATIVE-P (CONS ':RELATIVE STRS))
- ((NULL STRS) ':ROOT)
- ((NULL (CDR STRS)) (CAR STRS))
- (T STRS))))))
- (AND TYPE (PSETQ END TYPE
- TYPE (SUBSTRING NAMESTRING (1+ TYPE) END)))
- (SETQ NAME (AND ( START END) (SUBSTRING NAMESTRING START END)))
- (VALUES ':UNSPECIFIC DIR NAME TYPE ':NEWEST))
+ (SETQ END (1+ (OR (STRING-REVERSE-SEARCH-NOT-CHAR #\SP NAMESTRING END START)
+ (1- START))))
+ (SETQ DELIM-CHAR (FUNCALL-SELF ':DIRECTORY-DELIMITER-CHARACTER))
+ (LET (I)
+ (IF (AND (SETQ I (STRING-SEARCH-CHAR #\SP NAMESTRING START END))
+ (CHAR-EQUAL DELIM-CHAR (AREF NAMESTRING (1- END)))
+ (NOT (STRING-SEARCH-CHAR DELIM-CHAR NAMESTRING START I)))
+ (SETQ DIRSTART (STRING-SEARCH-NOT-CHAR #\SP NAMESTRING I END)
+ DIREND END
+ END I)
+ (SETQ DIRSTART START
+ DIREND (STRING-REVERSE-SEARCH-CHAR DELIM-CHAR NAMESTRING END START)
+ START (IF DIREND (1+ DIREND) START))))
+ ;; Now START..END are the indices around the name and type,
+ ;; and DIRSTART..DIREND are the indices around the directory.
+ (WHEN DIREND
+ (SETQ DIR (LET ((RELATIVE-P T)
+ (DIRIDX DIRSTART)
+ (UP (FUNCALL-SELF ':DIRECTORY-UP-DELIMITER))
+ (NUP NIL)
+ (STRS NIL))
+ (COND ((= (AREF NAMESTRING DIRIDX) DELIM-CHAR)
+ (SETQ RELATIVE-P NIL)
+ (SETQ DIRIDX (STRING-SEARCH-NOT-CHAR
+ DELIM-CHAR NAMESTRING DIRIDX))))
+ (AND DIRIDX (> DIREND DIRIDX)
+ (SETQ STRS (LOOP FOR IDX = DIRIDX THEN JDX
+ AS JDX = (STRING-SEARCH-CHAR
+ DELIM-CHAR NAMESTRING IDX DIREND)
+ COLLECT (SUBSTRING NAMESTRING IDX (OR JDX DIREND))
+ WHILE
+ (AND JDX
+ (SETQ JDX
+ (STRING-SEARCH-NOT-CHAR
+ DELIM-CHAR NAMESTRING JDX DIREND))))))
+ (AND (STRINGP UP)
+ (DO L STRS (CDR L) (NULL L)
+ (AND (STRING-EQUAL (CAR L) UP)
+ (SETF (CAR L) ':UP))))
+ (AND NUP (SETQ STRS (NCONC NUP STRS)))
+ (COND (RELATIVE-P (CONS ':RELATIVE STRS))
+ ((NULL STRS) ':ROOT)
+ ((NULL (CDR STRS)) (CAR STRS))
+ (T STRS)))))
+ (SETQ TYP (STRING-REVERSE-SEARCH-CHAR #/. NAMESTRING END START))
+ (IF (EQ TYP START) (SETQ TYP NIL)) ;Initial . is part of NAM
+ (IF TYP (PSETQ END TYP
+ TYP (SUBSTRING NAMESTRING (1+ TYP) END)))
+ (SETQ NAM (AND ( START END) (SUBSTRING NAMESTRING START END)))
+ (COND ((EQUAL NAM "'") (SETQ NAM NIL))
+ ((EQUAL NAM "*") (SETQ NAM ':WILD)))
+ (COND ((NULL TYP) (SETQ TYP (AND NAM ':UNSPECIFIC)))
+ ((EQUAL TYP "'") (SETQ TYP NIL))
+ ((EQUAL TYP "*") (SETQ TYP ':WILD VER ':WILD)))
+ ;; VER is :UNSPECIFIC unless TYP is :WILD, in which case VER is also :WILD.
+ (VALUES ':UNSPECIFIC DIR NAM TYP VER))
+
+;(DEFMETHOD (UNIX-PATHNAME-MIXIN :NEW-PATHNAME) (&REST OPTIONS &AUX (PLIST (LOCF OPTIONS)))
+; (LEXPR-FUNCALL #'MAKE-PATHNAME-1
+; ':NAME (OR (GET PLIST ':NAME) SELF)
+; ':VERSION (IF (EQ (OR (GET PLIST ':TYPE) (PATHNAME-TYPE (OR (GET PLIST ':NAME) SELF))) ':WILD) ':WILD ':UNSPECIFIC)
+; OPTIONS))
+
+(DEFMETHOD (UNIX-PATHNAME-MIXIN :PARSE-DIRECTORY-SPEC) (SPEC)
+ (COND ((STRINGP SPEC) (LIST (FUNCALL-SELF ':PARSE-COMPONENT-SPEC SPEC)))
+ ((EQ SPEC ':ROOT) SPEC)
+ ((AND (LISTP SPEC)
+ (LOOP FOR ELT IN SPEC
+ ALWAYS (OR (MEMQ ELT '(:UP :WILD :RELATIVE))
+ (STRINGP ELT)))
+ (NOT (MEMQ ':RELATIVE (CDR SPEC))))
+ (LOOP FOR ELT IN SPEC
+ COLLECT (IF (SYMBOLP ELT) ELT
+ (FUNCALL-SELF ':PARSE-COMPONENT-SPEC ELT))))
+ ((MEMQ SPEC '(NIL :UNSPECIFIC :WILD)) SPEC)
+ (T (PATHNAME-DIRECTORY (USER-HOMEDIR HOST)))))
-(DEFMETHOD (UNIX-PATHNAME-MIXIN :PARSE-STRUCTURED-DIRECTORY-SPEC) PATHNAME-PASS-THROUGH-SPEC)
+;(DEFMETHOD (UNIX-PATHNAME-MIXIN :PARSE-STRUCTURED-DIRECTORY-SPEC) PATHNAME-PASS-THROUGH-SPEC)
(DEFFLAVOR MULTICS-PATHNAME-MIXIN () (UNIX-PATHNAME-MIXIN))
More information about the mit-cadr-cvs
mailing list