;;;-*- Mode:LISP; Package:TV -*- ;;; Tree scroll an invention of MMcM. Hierarchy edit by BSG. (DEFFLAVOR BASIC-TREE-SCROLL ((CURRENT-TREE NIL)) (SCROLL-MOUSE-MIXIN SCROLL-WINDOW-WITH-TYPEOUT) :GETTABLE-INSTANCE-VARIABLES) (DEFMETHOD (BASIC-TREE-SCROLL :SET-TREE) (TREE) (SETQ CURRENT-TREE TREE) (FUNCALL-SELF ':SET-DISPLAY-ITEM (FUNCALL TREE ':SCROLL-ITEM))) (DEFFLAVOR TREE (OBJECT PRINT-STRING INDENTATION (INFERIORS NIL) (SUPERIOR NIL) (INFERIORS-VISIBLE NIL)) () :GETTABLE-INSTANCE-VARIABLES :INITABLE-INSTANCE-VARIABLES (:SETTABLE-INSTANCE-VARIABLES INFERIORS-VISIBLE OBJECT)) (DEFMETHOD (TREE :SCROLL-ITEM) (&OPTIONAL (INDENT 0)) (SETQ INDENTATION INDENT) (FUNCALL-SELF ':LINE-REDISPLAY) (LIST () (SCROLL-PARSE-ITEM ':MOUSE `(TREE-MOUSE ,SELF) `(:FUNCTION ,SELF (:PRINT-STRING))) (SCROLL-MAINTAIN-LIST `(LAMBDA () (FUNCALL ',SELF ':VISIBLE-INFERIORS)) `(LAMBDA (TREE) (FUNCALL TREE ':SCROLL-ITEM ,(1+ INDENT)))))) (DEFMETHOD (TREE :LINE-REDISPLAY) () (SETQ PRINT-STRING (LET ((STRING (WITH-OUTPUT-TO-STRING (STREAM) (DOTIMES (I INDENTATION) (FUNCALL STREAM ':TYO #\SP)) (FUNCALL-SELF ':DISPLAY-OBJECT STREAM)))) (STRING-TRIM '(#\CR) STRING)))) (DEFMETHOD (TREE :DISPLAY-OBJECT) (STREAM) (PRIN1 OBJECT STREAM)) (DEFMETHOD (TREE :VISIBLE-INFERIORS) () (AND INFERIORS-VISIBLE INFERIORS)) (DEFMETHOD (TREE :OPEN-OBJECT) () (FUNCALL-SELF ':SET-INFERIORS-VISIBLE T)) (DEFMETHOD (TREE :CLOSE-OBJECT) () (FUNCALL-SELF ':SET-INFERIORS-VISIBLE NIL)) (DEFFLAVOR MOUSABLE-TREE-SCROLL-MIXIN () () (:INCLUDED-FLAVORS BASIC-TREE-SCROLL)) (DEFMETHOD (MOUSABLE-TREE-SCROLL-MIXIN :TREE-INTERPRET-CHAR) (CH) (COND ((CHAR-EQUAL CH #/Q) (FUNCALL-SELF ':BURY)) ((CHAR-EQUAL CH #\CLEAR-SCREEN) (FUNCALL-SELF ':REDISPLAY T)) (T (TV:BEEP)))) (DEFMETHOD (MOUSABLE-TREE-SCROLL-MIXIN :TREE-INTERPRET-BLIP) (BLIP) (SELECTQ (FIRST BLIP) (TREE-MOUSE (LET ((TREE (SECOND (SECOND BLIP)))) (SELECTQ (FOURTH BLIP) (#\MOUSE-1-1 (FUNCALL TREE ':OPEN-OBJECT)) (#\MOUSE-2-1 (LET ((PARENT (FUNCALL TREE ':SUPERIOR))) (IF PARENT (FUNCALL PARENT ':CLOSE-OBJECT) (TV:BEEP)))) (#\MOUSE-3-1 (FUNCALL-SELF ':EDIT-OBJECT TREE))))))) (DEFMETHOD (MOUSABLE-TREE-SCROLL-MIXIN :WHO-LINE-DOCUMENTATION-STRING) () "L: Open object. M: Close containing object. R: Edit object.") (DEFFLAVOR TREE-SCROLL-WINDOW () (TV:PROCESS-MIXIN MOUSABLE-TREE-SCROLL-MIXIN BASIC-TREE-SCROLL)) (DEFMETHOD (TREE-SCROLL-WINDOW :BEFORE :INIT) (&REST IGNORE) (OR TV:PROCESS (SETQ TV:PROCESS '(TREE-TOP-LEVEL :SPECIAL-PDL-SIZE 4000 :REGULAR-PDL-SIZE 10000)))) (DEFUN TREE-TOP-LEVEL (WINDOW) (DO ((CH) (TERMINAL-IO (FUNCALL WINDOW ':TYPEOUT-WINDOW))) (NIL) (*CATCH 'SYS:COMMAND-LEVEL (SETQ CH (FUNCALL WINDOW ':TYI)) (IF (ATOM CH) (FUNCALL WINDOW ':TREE-INTERPRET-CHAR CH) (FUNCALL WINDOW ':TREE-INTERPRET-BLIP CH))) (FUNCALL WINDOW ':REDISPLAY))) (COMPILE-FLAVOR-METHODS BASIC-TREE-SCROLL MOUSABLE-TREE-SCROLL-MIXIN TREE TREE-SCROLL-WINDOW) ;;;-------------------------------------------------------------------------------- ;; I dont think anybody uses list-trees. (DEFFLAVOR LIST-TREE () (TREE)) (DEFMETHOD (LIST-TREE :AFTER :INIT) (IGNORE) (AND (LISTP OBJECT) (SETQ INFERIORS (LOOP FOR X IN OBJECT COLLECT (MAKE-INSTANCE 'LIST-TREE ':OBJECT X ':SUPERIOR SELF))))) (DEFUN MAKE-TREE-FROM-LIST (LIST) (MAKE-INSTANCE 'LIST-TREE ':OBJECT LIST)) (COMPILE-FLAVOR-METHODS LIST-TREE) ;;;-------------------------------------------------------------------------------- (DEFFLAVOR FILE-TREE () (TREE) ) (DEFMETHOD (FILE-TREE :DISPLAY-OBJECT) (STREAM) (ZWEI:DEFAULT-LIST-ONE-FILE OBJECT STREAM)) (DEFMETHOD (FILE-TREE :EDIT) (WINDOW) (TREE-EDIT-FILE SELF WINDOW)) (DEFFLAVOR DIRECTORY-TREE ((DIR-IN-DIR-FORM) (INFERIORS-PATHNAME NIL) (MATCH-PATHNAME NIL)) (TREE) (:INITABLE-INSTANCE-VARIABLES DIR-IN-DIR-FORM) (:GETTABLE-INSTANCE-VARIABLES DIR-IN-DIR-FORM) (:SETTABLE-INSTANCE-VARIABLES MATCH-PATHNAME)) (DEFMETHOD (DIRECTORY-TREE :DECACHE-INFERIORS) () (SETQ INFERIORS-PATHNAME NIL)) (DEFMETHOD (DIRECTORY-TREE :BEFORE :VISIBLE-INFERIORS) () (IF (NULL MATCH-PATHNAME) (FUNCALL-SELF ':DEFAULT-MATCH-PATHNAME)) ;take this out, window sys problems occur ;when you try to abort the chaos error. (OR (NOT INFERIORS-VISIBLE) INFERIORS-PATHNAME (SETQ INFERIORS-PATHNAME MATCH-PATHNAME INFERIORS (FUNCALL-SELF ':GENERATE-INFERIORS-LIST)))) (DEFMETHOD (DIRECTORY-TREE :GENERATE-INFERIORS-LIST) () (LOOP FOR FILE IN (SORT (CDR (FUNCALL MATCH-PATHNAME ':LIST-DIR-NO-SUBDIR-INFO ':DELETED)) #'TREE-EDIT-SORT) COLLECT (OR (DOLIST (OLD-INF INFERIORS) ;; EQ pathnamery depended upon here! (COND ((EQ (CAR (FUNCALL OLD-INF ':OBJECT)) (CAR FILE)) (SETQ INFERIORS (DELQ OLD-INF INFERIORS)) (FUNCALL OLD-INF ':SET-OBJECT FILE) (RETURN OLD-INF)))) (MAKE-INSTANCE (IF (GET FILE ':DIRECTORY) 'DIRECTORY-TREE 'FILE-TREE) ':OBJECT FILE ':SUPERIOR SELF)))) (DEFMETHOD (DIRECTORY-TREE :AFTER :INIT) (IGNORE) (IF (NULL DIR-IN-DIR-FORM) (AND (BOUNDP 'OBJECT) ;could be root-topnode --- ;which, believe it or not, should be ;a subflavor of this flavor... (SETQ DIR-IN-DIR-FORM (FUNCALL (CAR OBJECT) ':PATHNAME-AS-DIRECTORY)))) (IF (NULL MATCH-PATHNAME) (FUNCALL-SELF ':DEFAULT-MATCH-PATHNAME))) (DEFMETHOD (DIRECTORY-TREE :BEFORE :OPEN-OBJECT) () (FUNCALL-SELF ':DEFAULT-MATCH-PATHNAME)) (DEFMETHOD (DIRECTORY-TREE :EDIT) (WINDOW) (TREE-EDIT-DIRECTORY SELF WINDOW)) (DEFUN WILDIFY-PATHNAME (PATHNAME) (FUNCALL PATHNAME ':NEW-PATHNAME ':NAME ':WILD ':TYPE ':WILD ':VERSION ':WILD)) (DEFMETHOD (DIRECTORY-TREE :DEFAULT-MATCH-PATHNAME) () (FUNCALL-SELF ':SET-MATCH-PATHNAME (WILDIFY-PATHNAME DIR-IN-DIR-FORM))) (DEFMETHOD (DIRECTORY-TREE :AFTER :SET-MATCH-PATHNAME) (IGNORE) (IF (NULL (FUNCALL MATCH-PATHNAME ':VERSION)) ;dont let fs:directory-list default it.Mike? (SETQ MATCH-PATHNAME (FUNCALL MATCH-PATHNAME ':NEW-VERSION ':UNSPECIFIC))) (SETQ INFERIORS-PATHNAME NIL)) ;cause re-listing (DEFUN TREE-EDIT-SORT (F1 F2) (LET ((PN1 (CAR F1)) (PN2 (CAR F2)) (1DIR (NOT (NULL (GET F1 ':DIRECTORY)))) (2DIR (NOT (NULL (GET F2 ':DIRECTORY))))) (IF (EQ 1DIR 2DIR) (FS:PATHNAME-LESSP PN1 PN2) 1DIR))) (DEFMETHOD (DIRECTORY-TREE :AFTER :SET-INFERIORS-VISIBLE) (IGNORE) (FUNCALL-SELF ':LINE-REDISPLAY)) (DEFMETHOD (DIRECTORY-TREE :DISPLAY-OBJECT) (STREAM) (IF (NOT (ZEROP INDENTATION)) (FORMAT STREAM "~A " (IF (GET OBJECT ':DELETED) "D" " "))) (IF INFERIORS-VISIBLE (PROGN (IF (NULL INFERIORS-PATHNAME) (FUNCALL-SELF ':VISIBLE-INFERIORS)) (FORMAT STREAM "~A" MATCH-PATHNAME)) (FORMAT STREAM "~A" (FUNCALL DIR-IN-DIR-FORM ':STRING-FOR-DIRECTORY)))) (DEFFLAVOR TREE-LIST-TOPNODE () (DIRECTORY-TREE) (:DEFAULT-INIT-PLIST :INDENTATION 0 :INFERIORS-VISIBLE T)) (DEFMETHOD (TREE-LIST-TOPNODE :AFTER :INIT) (&REST IGNORE) (FUNCALL-SELF ':VISIBLE-INFERIORS)) (DEFFLAVOR TREE-LIST-ROOT-TOPNODE (SAMPLE-PATH PRINREP OPEN-PRINREP ROOT-MEANINGFUL-P) (TREE-LIST-TOPNODE) (:INITABLE-INSTANCE-VARIABLES SAMPLE-PATH PRINREP) (:DEFAULT-INIT-PLIST :PRINREP "All Directories")) (DEFMETHOD (TREE-LIST-ROOT-TOPNODE :BEFORE :INIT) (&REST IGNORE) (SETQ ROOT-MEANINGFUL-P (NOT (NULL (MEMQ ':DIRECTORY-PATHNAME-AS-FILE (FUNCALL SAMPLE-PATH ':WHICH-OPERATIONS)))))) (DEFMETHOD (TREE-LIST-ROOT-TOPNODE :AFTER :INIT) (&REST IGNORE) (IF ROOT-MEANINGFUL-P (SETQ DIR-IN-DIR-FORM (FUNCALL SAMPLE-PATH ':NEW-DIRECTORY ':ROOT) PRINREP (FUNCALL DIR-IN-DIR-FORM ':STRING-FOR-DIRECTORY)) (SETQ PRINREP (STRING-APPEND "All Directories - " (FUNCALL (FUNCALL SAMPLE-PATH ':HOST) ':STRING-FOR-PRINTING)))) (IF (NULL OPEN-PRINREP) (SETQ OPEN-PRINREP PRINREP))) (DEFMETHOD (TREE-LIST-ROOT-TOPNODE :DISPLAY-OBJECT) (STREAM) (IF INFERIORS-VISIBLE (PRINC OPEN-PRINREP STREAM) (PRINC PRINREP STREAM))) (DEFMETHOD (TREE-LIST-ROOT-TOPNODE :DEFAULT-MATCH-PATHNAME) (&REST IGNORE) (SETQ MATCH-PATHNAME (FUNCALL SAMPLE-PATH ':NEW-PATHNAME ':DIRECTORY ':ROOT ':NAME ':WILD ':TYPE ':WILD ':VERSION ':WILD ) OBJECT (LIST MATCH-PATHNAME ':DIRECTORY ':SORT-OF)) (IF ROOT-MEANINGFUL-P (SETQ OPEN-PRINREP (FUNCALL MATCH-PATHNAME ':STRING-FOR-PRINTING)))) (DEFMETHOD (TREE-LIST-ROOT-TOPNODE :EDIT) (WINDOW) (IF ROOT-MEANINGFUL-P (TREE-EDIT-DIRECTORY SELF WINDOW) (TREE-EDIT-ILLEGAL SELF WINDOW))) (DEFMETHOD (TREE-LIST-ROOT-TOPNODE :GENERATE-INFERIORS-LIST) () (LOOP FOR FILE IN (SORT (FUNCALL SAMPLE-PATH ':LIST-ROOT) #'TREE-EDIT-SORT) COLLECT (OR (DOLIST (OLD-INF INFERIORS) ;; EQ pathnamery depended upon here! (COND ((EQ (CAR (FUNCALL OLD-INF ':OBJECT)) (CAR FILE)) (SETQ INFERIORS (DELQ OLD-INF INFERIORS)) (FUNCALL OLD-INF ':SET-OBJECT FILE) (RETURN OLD-INF)))) (IF (GET FILE ':DIRECTORY) (MAKE-INSTANCE 'DIRECTORY-TREE ':DIR-IN-DIR-FORM (CAR FILE) ':SUPERIOR SELF ':Object FILE) ;shouldn't use but for above compare (MAKE-INSTANCE 'FILE-TREE ':OBJECT FILE ':SUPERIOR SELF))))) (COMPILE-FLAVOR-METHODS FILE-TREE DIRECTORY-TREE TREE-LIST-TOPNODE TREE-LIST-ROOT-TOPNODE) ;;;---------------------------------------------------------------------- (DEFFLAVOR HIERARCHY-EDITOR () (TREE-SCROLL-WINDOW) (:DEFAULT-INIT-PLIST :SAVE-BITS ':DELAYED)) (DEFMETHOD (HIERARCHY-EDITOR :WHO-LINE-DOCUMENTATION-STRING) () "L: Open directory. M: Close containing directory. R: Menu") (DEFMETHOD (HIERARCHY-EDITOR :BEFORE :INIT) (IGNORE) (OR TV:PROCESS (SETQ TV:PROCESS '(HIERARCHY-TOP-LEVEL :SPECIAL-PDL-SIZE 4000 :REGULAR-PDL-SIZE 10000)))) (DEFUN HIERARCHY-TOP-LEVEL (WINDOW) (LET ((TERMINAL-IO (FUNCALL WINDOW ':TYPEOUT-WINDOW))) (OR (FUNCALL WINDOW ':CURRENT-TREE) (FUNCALL WINDOW ':SET-TREE (MAKE-INSTANCE 'ROOT-DIRECTORY))) (TREE-TOP-LEVEL WINDOW))) (DEFMETHOD (HIERARCHY-EDITOR :EDIT-OBJECT) (TREE) (FUNCALL TREE ':EDIT SELF)) (COMPILE-FLAVOR-METHODS HIERARCHY-EDITOR) (DEFUN TREE-EDIT-DIRECTORY (TREE WINDOW) (LET* ((OBJECT (FUNCALL TREE ':OBJECT)) (PATHNAME (CAR OBJECT)) (DIRPATH (FUNCALL TREE ':DIR-IN-DIR-FORM)) (CHOICE (MENU-CHOOSE `(,(IF (GET OBJECT ':DELETED) '("Undelete" :VALUE :UNDELETE :DOCUMENTATION "Undelete this directory.") '("Delete" :VALUE :DELETE :DOCUMENTATION "Mark this directory as deleted.")) ,@(IF (FUNCALL TREE ':INFERIORS-VISIBLE) (LIST '("Close" :VALUE :CLOSE :DOCUMENTATION "Remove listing of inferiors from display.") '("Decache" :VALUE :DECACHE :DOCUMENTATION "Recompute display of this directory from latest data")) (LIST '("Open" :VALUE :OPEN :DOCUMENTATION "List inferiors to this display.") '("Selective open" :VALUE :SEL-OPEN :DOCUMENTATION "Open to selected files in this directory."))) ("Expunge" :VALUE :EXPUNGE :DOCUMENTATION "Remove all deleted files in this directory") ("Create Inferior Directory" :VALUE :CRDIR :DOCUMENTATION "Create a new directory inferior to this directory") ("View Properties" :VALUE :VIEW-PROPERTIES :DOCUMENTATION "View all available information about this directory.") ("Edit Properties" :VALUE :EDIT-PROPERTIES :DOCUMENTATION "Edit properties of directory") ("New Property" :VALUE :PUTPROP :DOCUMENTATION "Add or remove a user-defined file property from this directory") ("Create link" :VALUE :LINK :DOCUMENTATION "Create a file system link.") ("Rename" :VALUE :RENAME :DOCUMENTATION "Rename this directory.") ("Link Transparencies" :VALUE :LINK-XPAR :DOCUMENTATION "Edit default link transparency attributes.") ("Dump" :VALUE :DUMP :DOCUMENTATION "Invoke the backup dumper on this directory and all its inferiors.")) (STRING-APPEND "Directory operations: " (FUNCALL DIRPATH ':STRING-FOR-DIRECTORY)) '(:MOUSE) NIL WINDOW))) (SELECTQ CHOICE (:LINK-XPAR (LET ((CHANGE-RESULT (TREE-EDIT-TRANSPARENCIES (FORMAT NIL "Default link transparencies for ~A" (FUNCALL DIRPATH ':STRING-FOR-DIRECTORY)) (TREE-EDIT-ATTRIBUTE-UPDATE OBJECT ':DEFAULT-LINK-TRANSPARENCIES)))) (IF CHANGE-RESULT (FS:CHANGE-FILE-PROPERTIES PATHNAME T ':DEFAULT-LINK-TRANSPARENCIES CHANGE-RESULT)))) (:LINK (LET ((FILEPATH (TREE-EDIT-READ-LOCAL-PATH DIRPATH "File name of the link itself? "))) (COND ((NULL FILEPATH)) ;punt ((FUNCALL FILEPATH ':DIRECTORY) (FORMAT T "You may not specify a directory here.")) (T (LET ((TARGET (TREE-EDIT-READ-LOCAL-PATH FILEPATH "Path to link to? (target) "))) (IF TARGET (LET ((RESULT (FUNCALL (FUNCALL FILEPATH ':NEW-DIRECTORY (FUNCALL DIRPATH ':DIRECTORY)) ':CREATE-LINK TARGET))) (IF (EQ RESULT T) (FUNCALL TREE ':DECACHE-INFERIORS) (FORMAT T "~&~A" RESULT))))))) (TREE-EDIT-END-TYPEOUT))) (:EXPUNGE (MULTIPLE-VALUE-BIND (RECORDS ERRORS) (FUNCALL (FUNCALL TREE ':MATCH-PATHNAME) ':EXPUNGE) (FORMAT T "~&~D record~:P reclaimed." RECORDS) (IF (AND ERRORS (LISTP ERRORS)) (PROGN (FORMAT T "~&There were errors encountered:") (MAPC 'PRINT ERRORS)) (FORMAT T "~&There were no errors encountered."))) (FUNCALL TREE ':DECACHE-INFERIORS) (TREE-EDIT-END-TYPEOUT)) (:CRDIR (IF (EQ (TREE-EDIT-CREATE-DIR DIRPATH) T) (FUNCALL TREE ':DECACHE-INFERIORS)) (TREE-EDIT-END-TYPEOUT)) (:DECACHE (FUNCALL TREE ':DECACHE-INFERIORS)) (:OPEN (FUNCALL TREE ':DEFAULT-MATCH-PATHNAME) (FUNCALL TREE ':SET-INFERIORS-VISIBLE T)) (:SEL-OPEN (DO () (()) (LET ((STARPATH (TREE-EDIT-READ-LOCAL-PATH DIRPATH "File name to match as starname:"))) (IF STARPATH (IF (FUNCALL STARPATH ':DIRECTORY) (TV:NOTIFY NIL "Don't specify a directory, please") (PROGN (FUNCALL TREE ':SET-MATCH-PATHNAME (FUNCALL STARPATH ':NEW-PATHNAME ':DIRECTORY (FUNCALL DIRPATH ':DIRECTORY) ':DEVICE (FUNCALL DIRPATH ':DEVICE))) (FUNCALL TREE ':SET-INFERIORS-VISIBLE T) (RETURN))))))) (:CLOSE (FUNCALL TREE ':SET-INFERIORS-VISIBLE NIL)) (:DUMP (LMFS:BACKUP-DUMPER ':DUMP-TYPE ':COMPLETE ':START-PATH (WILDIFY-PATHNAME DIRPATH)) (TREE-EDIT-END-TYPEOUT)) (T (COND ((MEMQ ':DIRECTORY-PATHNAME-AS-FILE (FUNCALL DIRPATH ':WHICH-OPERATIONS)) (TREE-EDIT-COMMON CHOICE OBJECT (FUNCALL DIRPATH ':DIRECTORY-PATHNAME-AS-FILE) TREE)) (T (FORMAT T "~&Directory attribute operations are not supported on this file system.") (TREE-EDIT-END-TYPEOUT))))))) (DEFUN TREE-EDIT-FILE (TREE WINDOW) (LET* ((OBJECT (FUNCALL TREE ':OBJECT)) (PATHNAME (CAR OBJECT)) (CHOICE (MENU-CHOOSE `(,(IF (GET OBJECT ':DELETED) '("Undelete" :VALUE :UNDELETE :DOCUMENTATION "Undelete this file.") '("Delete" :VALUE :DELETE :DOCUMENTATION "Delete this file")) ,@ (IF (GET OBJECT ':LINK-TO) (LIST '("Edit Link Transparencies" :VALUE :EDIT-LINK-TRANSPARENCIES :DOCUMENTATION "Edit link transparency properties"))) ("View" :VALUE :VIEW :DOCUMENTATION "Print out the contents of this file.") ("Rename":VALUE :RENAME :DOCUMENTATION "Rename this file.") ("View Properties" :VALUE :VIEW-PROPERTIES :DOCUMENTATION "View all known information about this file") ("Edit Properties" :VALUE :EDIT-PROPERTIES :DOCUMENTATAION "Edit properties of file") ("New Property" :VALUE :PUTPROP :DOCUMENTATION "Add or remove a user-defined file property from this file") ("Hardcopy" :VALUE :HARDCOPY "Print this file on the local hardcopy device") ("Dump" :VALUE :DUMP :DOCUMENTATION "Dump this file to tape.")) (STRING-APPEND "File operations: " (STRING PATHNAME)) '(:MOUSE) NIL WINDOW))) (SELECTQ CHOICE (:EDIT-LINK-TRANSPARENCIES (LET ((CHANGE-RESULT (TREE-EDIT-TRANSPARENCIES (FORMAT NIL "Link transparency attributes for ~A" PATHNAME) (TREE-EDIT-ATTRIBUTE-UPDATE OBJECT ':LINK-TRANSPARENCIES)))) (IF CHANGE-RESULT (FS:CHANGE-FILE-PROPERTIES PATHNAME T ':LINK-TRANSPARENCIES CHANGE-RESULT)))) (:HARDCOPY (PROCESS-RUN-FUNCTION "FSEdit Hardcopy" 'PRESS:HARDCOPY-VIA-MENUS PATHNAME)) (:VIEW (WITH-OPEN-FILE (STREAM PATHNAME ':PRESERVE-DATES T ':DELETED T) (STREAM-COPY-UNTIL-EOF STREAM TERMINAL-IO)) (TREE-EDIT-END-TYPEOUT)) (:DUMP (LMFS:BACKUP-DUMPER ':DUMP-TYPE ':COMPLETE ':START-PATH PATHNAME) (TREE-EDIT-END-TYPEOUT)) (T (TREE-EDIT-COMMON CHOICE OBJECT PATHNAME TREE))))) (DEFUN TREE-EDIT-ILLEGAL (IGNORE IGNORE) (FORMAT T "~&Editing operations are not available at this level.") (TREE-EDIT-END-TYPEOUT)) (DEFUN TREE-EDIT-COMMON (CHOICE OBJECT PATHNAME TREE) (SELECTQ CHOICE (:EDIT-PROPERTIES (ZWEI:CHANGE-FILE-PROPERTIES PATHNAME)) (:RENAME (LET* ((NEWNAME (TREE-EDIT-READ-LOCAL-PATH PATHNAME "~&New name for ~A" PATHNAME))) (COND ((NULL NEWNAME)) ;punted or erred ((GET OBJECT ':DIRECTORY) (IF (OR (FUNCALL NEWNAME ':DIRECTORY) (FUNCALL NEWNAME ':TYPE) (FUNCALL NEWNAME ':VERSION)) (PROGN (FORMAT T "~&New directory name may not have directory, type, or version.") (SETQ NEWNAME NIL)) (SETQ NEWNAME (FUNCALL NEWNAME ':NEW-PATHNAME ':TYPE ':DIRECTORY ':VERSION 1)))) ((NULL (FUNCALL NEWNAME ':DIRECTORY)) (SETQ NEWNAME (FUNCALL NEWNAME ':NEW-DIRECTORY (FUNCALL PATHNAME ':DIRECTORY))))) (IF NEWNAME ;hasnt erred out yet.. (LET ((RESULT (RENAMEF PATHNAME NEWNAME))) (IF (EQ RESULT T) (FUNCALL (FUNCALL TREE ':SUPERIOR) ':DECACHE-INFERIORS) (FORMAT T "~&~A" RESULT)))))) (:DELETE (LET ((RESULT (FUNCALL PATHNAME ':DELETE))) (IF (EQ RESULT T) (PROGN (PUTPROP OBJECT T ':DELETED) (FUNCALL TREE ':LINE-REDISPLAY)) (FORMAT T "~&Can't delete ~A:~%~A" PATHNAME RESULT)))) (:UNDELETE (LET ((RESULT (FUNCALL PATHNAME ':CHANGE-PROPERTIES NIL ':DELETED NIL))) (IF (EQ RESULT T) (PROGN (PUTPROP OBJECT NIL ':DELETED) (FUNCALL TREE ':LINE-REDISPLAY)) (FORMAT T "~&Can't undelete ~A:~%~A" PATHNAME RESULT)))) (:VIEW-PROPERTIES (LET ((ATTR (FS:FILE-PROPERTIES PATHNAME NIL))) (IF (STRINGP ATTR) (FORMAT T "Error ~A for ~A" ATTR PATHNAME) (PROGN (FORMAT T "Properties for ~A~2%" PATHNAME) (LOOP FOR (IND PROP) ON (CDR ATTR) BY 'CDDR DO (FORMAT T "~&~A~30T" (ZWEI:PRETTY-COMMAND-NAME (STRING-APPEND IND))) ;he CLOBBERS! (FUNCALL (LOOP FOR ITEM IN FS:*KNOWN-DIRECTORY-PROPERTIES* FINALLY (RETURN #'PRINC) DO (IF (DOLIST (NAME (CDR ITEM)) (IF (STRING-EQUAL IND NAME) (RETURN T))) (RETURN (OR (CADAR ITEM) 'PRINC)))) PROP STANDARD-OUTPUT)))))) (:PUTPROP (LET ((PROP (ZWEI:TYPEIN-LINE-READLINE-NEAR-WINDOW ':MOUSE "Name of Property for ~A" PATHNAME))) (IF (NOT (EQ PROP T)) (LET ((VAL (ZWEI:TYPEIN-LINE-READLINE-NEAR-WINDOW ':MOUSE "String value of ~A for ~A (Null string REMPROPs)" (SETQ PROP (INTERN (STRING-UPCASE PROP) "")) PATHNAME))) (IF (EQUAL VAL "") (SETQ VAL NIL)) (COND ((EQ VAL T)) ((FS:CHANGE-FILE-PROPERTIES PATHNAME T PROP VAL))))))) ) ;end SELECTQ (TREE-EDIT-END-TYPEOUT) ) ;;; I would fix PEEK to do this if I could maintain that source... (DEFUN TREE-EDIT-END-TYPEOUT () (COND ((FUNCALL TERMINAL-IO ':INCOMPLETE-P) (FORMAT T "~&Type any character to flush:") (LET ((CHAR (FUNCALL TERMINAL-IO ':TYI))) (FUNCALL TERMINAL-IO ':MAKE-COMPLETE) ;; The change of substance is EQUAL here to make mouse blips not blow out (OR (EQUAL CHAR #\SPACE) (FUNCALL TERMINAL-IO ':UNTYI CHAR))))) (FUNCALL (FUNCALL TERMINAL-IO ':SUPERIOR) ':REDISPLAY)) (DEFUN TREE-EDIT-CREATE-DIR (PARCOND) ;in typeout window now (IF (AND (MEMQ ':DIRECTORY-PATHNAME-AS-FILE (FUNCALL PARCOND ':WHICH-OPERATIONS)) (GET (FUNCALL (FUNCALL PARCOND ':DIRECTORY-PATHNAME-AS-FILE) ':PROPERTIES) ':DELETED)) (FORMAT T "~&~A has been deleted" (FUNCALL PARCOND ':STRING-FOR-DIRECTORY)) (LET ((PARSED (TREE-EDIT-READ-LOCAL-PATH PARCOND "~&Please type file name for new directory, a son of ~A:~%" (FUNCALL PARCOND ':STRING-FOR-DIRECTORY)))) (COND ((NULL PARSED) (FORMAT T "~&Invalid file name.")) ((OR (FUNCALL PARSED ':DIRECTORY) (FUNCALL PARSED ':TYPE) (FUNCALL PARSED ':VERSION)) (FORMAT T "~&A file name only, please.")) (T (LET ((RESULT (OPEN (FUNCALL PARCOND ':NEW-NAME (FUNCALL PARSED ':NAME)) ':FLAVOR ':DIRECTORY))) (OR (EQ RESULT T) (FORMAT T "~&~A" RESULT)))))))) (DEFVAR *TREE-EDIT-READ-LOCAL-PATH-DEFAULT* NIL) (DEFUN TREE-EDIT-READ-LOCAL-PATH (DEFAULT-PATH &REST FORMAT-ARGS) (OR *TREE-EDIT-READ-LOCAL-PATH-DEFAULT* (SETQ *TREE-EDIT-READ-LOCAL-PATH-DEFAULT* (FS:PARSE-PATHNAME "local:>"))) (LET ((TYPEIN (LEXPR-FUNCALL #'ZWEI:TYPEIN-LINE-READLINE-NEAR-WINDOW ':MOUSE FORMAT-ARGS))) (IF (EQ TYPEIN T) ;he punted NIL (LET ((ANSWER (CAR (ERRSET (FS:PARSE-PATHNAME (STRING-TRIM " " TYPEIN) NIL (OR DEFAULT-PATH *TREE-EDIT-READ-LOCAL-PATH-DEFAULT*)) T)))) (IF (NULL ANSWER) (TREE-EDIT-END-TYPEOUT)) ANSWER)))) (DEFVAR *LINK-TRANSPARENCY-WINDOW* NIL) (DEFFLAVOR LINK-ATTRIBUTE-KEYWORD-MENU () (ZWEI:POP-UP-ZMAIL-MULTIPLE-MENU) (:DEFAULT-INIT-PLIST :COLUMNS 5 :SPECIAL-CHOICES '(("Abort" :VALUE :ABORT :DOCUMENTATION "Abort this command.") ("Do It" :VALUE :DO-IT :DOCUMENTATION "Use highlighted items.")))) (DEFUN TREE-EDIT-TRANSPARENCIES (LABEL CURRENT) (IF (NULL *LINK-TRANSPARENCY-WINDOW*) (SETQ *LINK-TRANSPARENCY-WINDOW* (TV:MAKE-WINDOW 'LINK-ATTRIBUTE-KEYWORD-MENU ':SUPERIOR SELECTED-WINDOW))) (FUNCALL *LINK-TRANSPARENCY-WINDOW* ':SET-LABEL LABEL) (MULTIPLE-VALUE-BIND (IGNORE NEW-TRANSPARENCIES) (FUNCALL *LINK-TRANSPARENCY-WINDOW* ':MULTIPLE-CHOOSE '(("Read" :VALUE :READ :DOCUMENTATION "Link is transparent to openings for reading.") ("Write" :VALUE :WRITE :DOCUMENTATION "Link is transparent to openings for appending") ("Create" :VALUE :CREATE :DOCUMENTATION "Files will be created through the link") ("Delete" :VALUE :DELETE :DOCUMENTATION "Deletion will occur through the link") ("Rename" :VALUE :RENAME :DOCUMENTATION "Object described by link will be renamed")) CURRENT) (IF (EQUAL NEW-TRANSPARENCIES CURRENT) ;nothing, ignore it, maybe guy aborted NIL (LIST ':READ (NOT (NULL (MEMQ ':READ NEW-TRANSPARENCIES))) ':WRITE (NOT (NULL (MEMQ ':WRITE NEW-TRANSPARENCIES))) ':CREATE (NOT (NULL (MEMQ ':CREATE NEW-TRANSPARENCIES))) ':DELETE (NOT (NULL (MEMQ ':DELETE NEW-TRANSPARENCIES))) ':RENAME (NOT (NULL (MEMQ ':RENAME NEW-TRANSPARENCIES))))))) (DEFUN TREE-EDIT-ATTRIBUTE-UPDATE (OBJECT IND) (LET ((PATHNAME (CAR OBJECT))) (LET ((PROPS (CDR (FS:FILE-PROPERTIES PATHNAME)))) ;blow out if loses (AND PROPS (RPLACD OBJECT PROPS)) ;beat those ^R typers... (IF IND ;could be random-update.. (OR (MEMQ IND (CDR OBJECT)) ;cd really be nil.. (FERROR NIL "Can't get ~A for ~A" (ZWEI:PRETTY-COMMAND-NAME (STRING-APPEND IND)) PATHNAME))) (AND IND (GET OBJECT IND))))) (DEFMETHOD (FS:PATHNAME :LIST-DIR-NO-SUBDIR-INFO) (&REST ARGS) (FUNCALL-SELF ':DIRECTORY-LIST ARGS)) (DEFMETHOD (FS:PATHNAME :LIST-ROOT) (&OPTIONAL OPTIONS) (LOOP FOR L IN (FUNCALL (FUNCALL-SELF ':NEW-DIRECTORY ':WILD) ':ALL-DIRECTORIES OPTIONS) COLLECT (LIST (CAR L) ':DIRECTORY T))) (DEFMETHOD (FS:MEANINGFUL-ROOT-MIXIN :LIST-ROOT) (&REST IGNORE) (LET ((WILDROOT (FUNCALL-SELF ':NEW-PATHNAME ':DIRECTORY ':ROOT ':NAME ':WILD ':TYPE ':WILD ':VERSION ':WILD))) (LOOP FOR FILE IN (FUNCALL WILDROOT ':LIST-DIR-NO-SUBDIR-INFO) COLLECT (CONS (AND (GET FILE ':DIRECTORY) (FUNCALL (CAR FILE) ':PATHNAME-AS-DIRECTORY)) (CDR FILE)))))