diff --git a/README-mac.md b/README-mac.md deleted file mode 100644 index 9ed40ded..00000000 --- a/README-mac.md +++ /dev/null @@ -1,24 +0,0 @@ -# Running Medley Interlisp on a Mac. - -Running on MacOS requires an X server, and building on a Mac requires X client libraries. An X-server for x86 can be freely obtained at https://www.xquartz.org/. For the new arm64 MacOS 11, you'll need https://x.org which you can get via MacPorts or Brew. - - -### Middle-mouse tweak - -if you don't have a 3-button mouse (wheel = middle mouse) -you can enable FN-left to be middle. Run in a terminal: - -```sh -defaults write org.macosforge.xquartz.X11 enable_fake_buttons -boolean true -defaults write org.macosforge.xquartz.X11 fake_button2 fn -defaults write org.macosforge.xquartz.X11 fake_button3 none -``` - -To turn the settings back to the original default values do: - -```sh -defaults write org.macosforge.xquartz.X11 enable_fake_buttons -boolean false -defaults delete org.macosforge.xquartz.X11 fake_button2 -defaults delete org.macosforge.xquartz.X11 fake_button3 -``` - diff --git a/README.md b/README.md index af140107..68295c36 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,13 @@ # Medley -This repo is for the Lisp environment of [Medley Interlisp](https://Interlisp.org). We've made great process in sorting out what we have (some dusty corners notwithstanding), but there's quite a bit more work to do. Please report problems! -See [Medley Interlisp Introduction](https://github.com/Interlisp/medley/wiki/Medley-Interlisp-Introduction) for an overview. + + + +This repository is for the Lisp environment of [Medley Interlisp](https://Interlisp.org). + +We've made great process in sorting out what we have (some dusty corners notwithstanding), but there's quite a bit more work to do. Please report problems! + +See [Medley Interlisp Wiki](https://github.com/Interlisp/medley/wiki/) for an overview, and other pointers. A sub-project is [Interlisp/maiko](https://github.com/Interlisp/maiko), which is the implementation (in C) of the Medley virtual machine. @@ -10,9 +16,10 @@ A sub-project is [Interlisp/maiko](https://github.com/Interlisp/maiko), which is ### Setting up X -Medley Interlisp needs an X-Server to manage its display. Most Linux desktops have one. -If you have a high-resolution display, note that much of the graphics was designed for a low-resolution display, so an X-server that does "pixel doublilng" is best. (E.g., Raspberry Pi does pixel doubling on 4K displayes). -* It also presumes you have a 3-button mouse (the scroll-wheel on some mice act as one with some difficulty.) See [README-mac.md](./README-mac.md) for more info on dealing with that. +Medley Interlisp needs an X-Server to manage its display. Most Linux desktops have one. There are a number of free open source X-servers for windows. Mac users should head over to [XQuartz.org](https://xquartz.org/releases) -- be sure to pick a version if you have a newer Mac. + +If you have a high-resolution display, note that much of the graphics was designed for a low-resolution display, so an X-server that does "pixel doublilng" is best. (E.g., Raspberry Pi does pixel doubling on 4K displays.) It also presumes you have a 3-button mouse; the scroll-wheel on some mice act as one with some difficulty.) XQuartz Preferences/Input has "Emulate three button mouse" option. + ### Running Medley Interlisp @@ -78,8 +85,8 @@ Each directory should have a README.md, but briefly - library -- packages that were supported (30 years ago) - lispusers -- packages that were only half supported (ditto) - loadups -- has sysouts and other builds -- makesysout -- files for making new sysouts for various configurations, based on basics - patches -- for cases where reloading doesn't wor +- scripts -- some scripts for fixing up things - sunloadup -- support information for making a new lisp.sysout from scratch - sources -- sources for Interlisp and Common Lisp implementations - unicode -- data files for support of XCCS to and from Unicode mappings diff --git a/library/CLIPBOARD b/library/CLIPBOARD index df4a12fb..dbe83449 100644 --- a/library/CLIPBOARD +++ b/library/CLIPBOARD @@ -1 +1 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 8-Aug-2020 15:48:08"  {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;53 7823 changes to%: (VARS CLIPBOARDCOMS) previous date%: " 8-Aug-2020 15:25:18" {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;52) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD LISPINTERRUPTS.PASTE) (FNS TEDIT.COPYTOCLIPBOARD TEDIT.EXTRACTTOCLIPBOARD) (FNS SEDIT.COPYTOCLIPBOARD) (INITVARS (CLIPBOARD-FORMAT :UTF8)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILES (SYSLOAD) UNIXCOMM UNICODE) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ; "Enable copy and paste") (DEFINEQ (INSTALL-CLIPBOARD [LAMBDA NIL (* ; "Edited 8-Aug-2020 07:59 by rmk:") (* ; "Edited 19-Apr-2020 12:15 by rmk:") (* ; "Edited 18-Apr-2018 23:00 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.PASTE) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.ORIG) (MOVD 'LISPINTERRUPTS.PASTE 'LISPINTERRUPTS)) (INTERRUPTCHAR (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (INTERRUPTCHAR (CHARCODE "1,V") '(PASTEFROMCLIPBOARD)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT") (* ;; "Paste") (TEDIT.SETFUNCTION (CHARCODE "1,v") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,V") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (* ;; "Copy") (TEDIT.SETFUNCTION (CHARCODE "1,c") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,C") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (* ;; "Extract") (TEDIT.SETFUNCTION (CHARCODE "1,X") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,x") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ; "SEDIT copy: INTERRUPTCHAR does paste") (SEDIT:ADD-COMMAND "1,c" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:ADD-COMMAND "1,C" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:RESET-COMMANDS))]) (GETCLIPBOARD [LAMBDA NIL (* ; "Edited 8-Aug-2020 07:56 by rmk:") (* ; "Edited 25-Apr-2018 16:56 by rmk:") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbpaste")) (\EXTERNALFORMAT s CLIPBOARD-FORMAT) [SETFILEINFO s 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (RETFROM (FUNCTION READCCODE) NIL] (CONCATCODES (BIND C WHILE (SETQ C (READCCODE s)) COLLECT C]) (PUTCLIPBOARD [LAMBDA (OBJECT PRINTFN) (* ; "Edited 8-Aug-2020 07:56 by rmk:") (* ; "Edited 25-Apr-2018 16:49 by rmk:") (* ;; "Clipboard is UNICODE and UTF8") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbcopy")) (\EXTERNALFORMAT s CLIPBOARD-FORMAT) (IF PRINTFN THEN (APPLY* PRINTFN OBJECT s) ELSE (PRIN3 OBJECT s]) (PASTEFROMCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 13:56 by rmk:") (* ; "Edited 17-Apr-2018 23:11 by rmk:") (* ;;  "Should be able to just call COPYINSERT, but the default BKSYSBUF puts in string qujotes ") (LET ((STR (GETCLIPBOARD))) (IF (WINDOWPROP (PROCESS.WINDOW (TTY.PROCESS)) 'COPYINSERTFN) THEN (COPYINSERT STR) ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C]) (LISPINTERRUPTS.PASTE [LAMBDA NIL (* ; "Edited 18-Apr-2018 22:59 by rmk:") (* ;; "So paste interrupts will be installed in every process") (APPEND [LIST (LIST (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (LIST (CHARCODE "1,V") '(PASTEFROMCLIPBOARD] (LISPINTERRUPTS.ORIG]) ) (DEFINEQ (TEDIT.COPYTOCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM]) (TEDIT.EXTRACTTOCLIPBOARD [LAMBDA NIL (* ; "Edited 19-Apr-2020 12:17 by rmk:") (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM)) (TEDIT.DELETE TEXTSTREAM (TEDIT.GETSEL TEXTSTREAM]) ) (DEFINEQ (SEDIT.COPYTOCLIPBOARD [LAMBDA (CONTEXT) (* ; "Edited 8-Aug-2020 15:25 by rmk:") (* ; "Edited 24-Apr-2018 20:39 by rmk:") (* ; "Edited 24-Apr-2018 20:33 by rmk:") (* ; "Edited 23-Apr-2018 18:19 by rmk:") [CL:MULTIPLE-VALUE-BIND (SEL SELTYPE) (SEDIT:GET-SELECTION CONTEXT) (* ;; "SEL could be a list of several elements, or a structure, depending on SELTYPE. ") (* ;; "SELTYPE=NIL means not a valid selection, and SEL is NIL. Non-NIL values are :SUB-LIST, :CHARACTERS, and T") (CL:WHEN SELTYPE [PUTCLIPBOARD (CONS SEL (EQ SELTYPE :SUB-LIST)) (FUNCTION (LAMBDA (PAIR STREAM) (LET ((*PRINT-PRETTY* T) (PRETTYTABFLG NIL) (FONTCHANGEFLG NIL) (%#RPARS NIL)) (DECLARE (SPECVARS *PRINT-PRETTY* %#RPARS PRETTYTABFLG FONTCHANGEFLG)) (PRINTDEF (CAR PAIR) 0 NIL (CDR PAIR) NIL STREAM])] T]) ) (RPAQ? CLIPBOARD-FORMAT :UTF8) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILESLOAD (SYSLOAD) UNIXCOMM UNICODE) (INSTALL-CLIPBOARD) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS CLIPBOARD COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1216 5170 (INSTALL-CLIPBOARD 1226 . 3048) (GETCLIPBOARD 3050 . 3649) (PUTCLIPBOARD 3651 . 4126) (PASTEFROMCLIPBOARD 4128 . 4745) (LISPINTERRUPTS.PASTE 4747 . 5168)) (5171 5930 ( TEDIT.COPYTOCLIPBOARD 5181 . 5462) (TEDIT.EXTRACTTOCLIPBOARD 5464 . 5928)) (5931 7470 ( SEDIT.COPYTOCLIPBOARD 5941 . 7468))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "23-Feb-2021 22:13:09"  {DSK}kaplan>Local>medley3.5>git-medley>library>CLIPBOARD.;52 9082 changes to%: (FNS CLIPBOARD-COPY-STREAM CLIPBOARD-PASTE-STREAM) previous date%: "23-Feb-2021 11:34:57" {DSK}kaplan>Local>medley3.5>git-medley>library>CLIPBOARD.;50) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD LISPINTERRUPTS.PASTE CLIPBOARD-COPY-STREAM CLIPBOARD-PASTE-STREAM) (FNS TEDIT.COPYTOCLIPBOARD TEDIT.EXTRACTTOCLIPBOARD) (FNS SEDIT.COPYTOCLIPBOARD) (INITVARS (CLIPBOARD-FORMAT :UTF8)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILES (SYSLOAD) UNIXCOMM UNICODE) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ; "Enable copy and paste") (DEFINEQ (INSTALL-CLIPBOARD [LAMBDA NIL (* ; "Edited 8-Aug-2020 07:59 by rmk:") (* ; "Edited 19-Apr-2020 12:15 by rmk:") (* ; "Edited 18-Apr-2018 23:00 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.PASTE) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.ORIG) (MOVD 'LISPINTERRUPTS.PASTE 'LISPINTERRUPTS)) (INTERRUPTCHAR (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (INTERRUPTCHAR (CHARCODE "1,V") '(PASTEFROMCLIPBOARD)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT") (* ;; "Paste") (TEDIT.SETFUNCTION (CHARCODE "1,v") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,V") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (* ;; "Copy") (TEDIT.SETFUNCTION (CHARCODE "1,c") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,C") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (* ;; "Extract") (TEDIT.SETFUNCTION (CHARCODE "1,X") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,x") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ; "SEDIT copy: INTERRUPTCHAR does paste") (SEDIT:ADD-COMMAND "1,c" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:ADD-COMMAND "1,C" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:RESET-COMMANDS))]) (GETCLIPBOARD [LAMBDA NIL (* ; "Edited 23-Feb-2021 11:32 by rmk:") (* ; "Edited 25-Apr-2018 16:56 by rmk:") (CL:WITH-OPEN-STREAM (s (CLIPBOARD-PASTE-STREAM)) (CONCATCODES (BIND C WHILE (SETQ C (READCCODE s)) COLLECT C]) (PUTCLIPBOARD [LAMBDA (OBJECT PRINTFN) (* ; "Edited 23-Feb-2021 11:32 by rmk:") (* ; "Edited 25-Apr-2018 16:49 by rmk:") (CL:WITH-OPEN-STREAM (s (CLIPBOARD-COPY-STREAM)) (IF PRINTFN THEN (APPLY* PRINTFN OBJECT s) ELSE (PRIN3 OBJECT s]) (PASTEFROMCLIPBOARD [LAMBDA NIL (* ; "Edited 15-Feb-2021 23:43 by rmk:") (* ; "Edited 18-Apr-2018 13:56 by rmk:") (* ; "Edited 17-Apr-2018 23:11 by rmk:") (* ;; "If for some reason TTY process doesn't have a window (e.g. TEXEC), we can only do the character printing. Presumably the right thing to do--no image objects in an exec.") (* ;; "Should be able to just call COPYINSERT, but the default BKSYSBUF puts in string quotes.") (LET [(STR (GETCLIPBOARD)) (WINDOW (PROCESS.WINDOW (TTY.PROCESS] (IF (AND WINDOW (WINDOWPROP WINDOW 'COPYINSERTFN)) THEN (COPYINSERT STR) ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C]) (LISPINTERRUPTS.PASTE [LAMBDA NIL (* ; "Edited 18-Apr-2018 22:59 by rmk:") (* ;; "So paste interrupts will be installed in every process") (APPEND [LIST (LIST (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (LIST (CHARCODE "1,V") '(PASTEFROMCLIPBOARD] (LISPINTERRUPTS.ORIG]) (CLIPBOARD-COPY-STREAM [LAMBDA NIL (* ; "Edited 23-Feb-2021 22:11 by rmk:") (* ;; "Clipboard is UNICODE and UTF8") (LET (STRM (OST (UNIX-GETENV "OSTYPE"))) (SETQ STRM (CREATE-PROCESS-STREAM (CL:IF (STRPOS "darwin" OST) "pbcopy" "xclip -i -selection clipboard"))) (\EXTERNALFORMAT STRM CLIPBOARD-FORMAT) STRM]) (CLIPBOARD-PASTE-STREAM [LAMBDA NIL (* ; "Edited 23-Feb-2021 17:29 by rmk:") (LET (STRM (OST (UNIX-GETENV "OSTYPE"))) (SETQ STRM (CREATE-PROCESS-STREAM (CL:IF (STRPOS "darwin" OST) "pbpaste" "xclip -o -selection clipboard"))) (\EXTERNALFORMAT STRM CLIPBOARD-FORMAT) [SETFILEINFO STRM 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (RETFROM (FUNCTION READCCODE) NIL] STRM]) ) (DEFINEQ (TEDIT.COPYTOCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM]) (TEDIT.EXTRACTTOCLIPBOARD [LAMBDA NIL (* ; "Edited 19-Apr-2020 12:17 by rmk:") (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM)) (TEDIT.DELETE TEXTSTREAM (TEDIT.GETSEL TEXTSTREAM]) ) (DEFINEQ (SEDIT.COPYTOCLIPBOARD [LAMBDA (CONTEXT) (* ; "Edited 8-Aug-2020 15:25 by rmk:") (* ; "Edited 24-Apr-2018 20:39 by rmk:") (* ; "Edited 24-Apr-2018 20:33 by rmk:") (* ; "Edited 23-Apr-2018 18:19 by rmk:") [CL:MULTIPLE-VALUE-BIND (SEL SELTYPE) (SEDIT:GET-SELECTION CONTEXT) (* ;; "SEL could be a list of several elements, or a structure, depending on SELTYPE. ") (* ;; "SELTYPE=NIL means not a valid selection, and SEL is NIL. Non-NIL values are :SUB-LIST, :CHARACTERS, and T") (CL:WHEN SELTYPE [PUTCLIPBOARD (CONS SEL (EQ SELTYPE :SUB-LIST)) (FUNCTION (LAMBDA (PAIR STREAM) (LET ((*PRINT-PRETTY* T) (PRETTYTABFLG NIL) (FONTCHANGEFLG NIL) (%#RPARS NIL)) (DECLARE (SPECVARS *PRINT-PRETTY* %#RPARS PRETTYTABFLG FONTCHANGEFLG)) (PRINTDEF (CAR PAIR) 0 NIL (CDR PAIR) NIL STREAM])] T]) ) (RPAQ? CLIPBOARD-FORMAT :UTF8) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILESLOAD (SYSLOAD) UNIXCOMM UNICODE) (INSTALL-CLIPBOARD) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS CLIPBOARD COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1309 6429 (INSTALL-CLIPBOARD 1319 . 3141) (GETCLIPBOARD 3143 . 3517) (PUTCLIPBOARD 3519 . 3924) (PASTEFROMCLIPBOARD 3926 . 4844) (LISPINTERRUPTS.PASTE 4846 . 5267) (CLIPBOARD-COPY-STREAM 5269 . 5769) (CLIPBOARD-PASTE-STREAM 5771 . 6427)) (6430 7189 (TEDIT.COPYTOCLIPBOARD 6440 . 6721) ( TEDIT.EXTRACTTOCLIPBOARD 6723 . 7187)) (7190 8729 (SEDIT.COPYTOCLIPBOARD 7200 . 8727))))) STOP \ No newline at end of file diff --git a/library/CLIPBOARD.LCOM b/library/CLIPBOARD.LCOM index 3d96ce94..c77009e5 100644 Binary files a/library/CLIPBOARD.LCOM and b/library/CLIPBOARD.LCOM differ diff --git a/library/CLIPBOARD.TXT b/library/CLIPBOARD.TXT new file mode 100644 index 00000000..78f0002a --- /dev/null +++ b/library/CLIPBOARD.TXT @@ -0,0 +1,17 @@ +library/CLIPBOARD + +Written by Ron Kaplan, 2020-2021 + +A small package that implements copy and paste to the system clipboard. + +It arms meta-C for copy to the clipboard from the current selection of an application that has been armed (Tedit, Sedit), and also meta-X for extraction (copy followed by delete). + +Meta-V is defined as an interrupt character that pastes the current clipboard contents into whatever process curent has input focus. + +The information in the clipboard can be provided from or provided to external (non-Medley) applications (mail, emacs, etc.) in the usual way. For example, a form cselected in SEDIT can be copied to the clipboard and pasted into an email message. + +It assumes that the clipboard is a utf-8/unicode stream, and uses the UNICODE package to convert to and from the Medley internal character encoding (XCCS). + +The name of the clipboard stream may differ from platform to platform. On the Mac, the paste stream is "pbpaste" and the copy stream is "pbcopy". Those names are used if "darwin" is a substring of (UNIX-GETENV "ostype"). Otherwise both stream-names default to "xclip". The functions CLIPBOARD-COPY-STREAM and CLIPBOARD-PASTE-STREAM perform this selection. + + diff --git a/library/CLIPBOARD.~21~ b/library/CLIPBOARD.~21~ deleted file mode 100644 index e6a179c9..00000000 --- a/library/CLIPBOARD.~21~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "28-Apr-2018 16:07:41"  {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;21 12278 changes to%: (FNS FILETOCODETABLE FILETOARRAYBLOCK CODECONVERT) (VARS CLIPBOARDCOMS) previous date%: "25-Apr-2018 17:56:28" {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;18) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD TEDIT.COPYTOCLIPBOARD SEDIT.COPYTOCLIPBOARD LISPINTERRUPTS.PASTE) (FNS UTF8.PRINTCCODE UTF8.READCCODE) (* ;; "To read/access code translation tables") (FNS FILETOCODETABLE CODECONVERT) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD) UNIXCOMM) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ; "Enable copy and paste") (DEFINEQ (INSTALL-CLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 23:00 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.PASTE) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.ORIG) (MOVD 'LISPINTERRUPTS.PASTE 'LISPINTERRUPTS)) (INTERRUPTCHAR (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (INTERRUPTCHAR (CHARCODE "1,V") '(PASTEFROMCLIPBOARD)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT") (* ;; "Paste") (TEDIT.SETFUNCTION (CHARCODE "1,v") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,V") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (* ;; "Copy") (TEDIT.SETFUNCTION (CHARCODE "1,c") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,C") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ;  "SEDIT copy: INTERRUPTCHAR does paste") (SEDIT:ADD-COMMAND "1,c" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:ADD-COMMAND "1,C" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:RESET-COMMANDS))]) (GETCLIPBOARD [LAMBDA NIL (* ; "Edited 25-Apr-2018 16:56 by rmk:") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbpaste")) [SETFILEINFO s 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (RETFROM (FUNCTION UTF8.READCCODE) NIL] (CONCATCODES (BIND C WHILE (SETQ C (UTF8.READCCODE s)) COLLECT C]) (PUTCLIPBOARD [CL:LAMBDA (STRING) (* ; "Edited 25-Apr-2018 16:49 by rmk:") (* ;; "Clipboard is UTF8") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbcopy")) (FOR I FROM 1 TO (NCHARS STRING) DO (UTF8.PRINTCCODE (NTHCHARCODE STRING I) s]) (PASTEFROMCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 13:56 by rmk:") (* ; "Edited 17-Apr-2018 23:11 by rmk:") (* ;;  "Should be able to just call COPYINSERT, but the default BKSYSBUF puts in string qujotes ") (LET ((STR (GETCLIPBOARD))) (IF (WINDOWPROP (PROCESS.WINDOW (TTY.PROCESS)) 'COPYINSERTFN) THEN (COPYINSERT STR) ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C]) (TEDIT.COPYTOCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM]) (SEDIT.COPYTOCLIPBOARD [LAMBDA (CONTEXT) (* ; "Edited 24-Apr-2018 20:43 by rmk:") (* ; "Edited 24-Apr-2018 20:39 by rmk:") (* ; "Edited 24-Apr-2018 20:33 by rmk:") (* ; "Edited 23-Apr-2018 18:19 by rmk:") (LET (SEL SELTYPE STRING) (* ;; "SEL could be a list of several elements, or a structure, depending on SELTYPE. ") (CL:MULTIPLE-VALUE-SETQ (SEL SELTYPE) (SEDIT:GET-SELECTION CONTEXT)) (* ;; "SELTYPE=NIL means not a valid selection, and SEL is NIL. Non-NIL values are :SUB-LIST, :CHARACTERS, and T") (IF SELTYPE THEN (SETQ STRING (MKSTRING SEL T)) (* ; " Readtable of caller?") (CL:WHEN (OR (EQ SELTYPE :CHARACTERS) (LISTP SEL)) (GNC STRING) (* ;  "Peel off outer parens for structures or quotes for atom/string characters") (GLC STRING)) (PUTCLIPBOARD STRING))) T]) (LISPINTERRUPTS.PASTE [LAMBDA NIL (* ; "Edited 18-Apr-2018 22:59 by rmk:") (* ;; "So paste interrupts will be installed in every process") (APPEND [LIST (LIST (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (LIST (CHARCODE "1,V") '(PASTEFROMCLIPBOARD] (LISPINTERRUPTS.ORIG]) ) (DEFINEQ (UTF8.PRINTCCODE [LAMBDA (CHARCODE FILE) (* ; "Edited 25-Apr-2018 17:56 by rmk:") (* ;; "PRINT UTF8 sequence for CHARACODE. Doesn't do XNS to Unicode character conversion, just does the transport encoding.") (LET [(STRM (\GETSTREAM FILE 'OUTPUT] (* ; "Output raw bytes") (IF (ILESSP CHARCODE 128) THEN (\BOUT STRM CHARCODE) ELSEIF (ILESSP CHARCODE 2048) THEN (* ; "x800") (\BOUT STRM (LOGOR (LLSH 3 6) (LRSH CHARCODE 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 65536) THEN (* ; "x10000") (\BOUT STRM (LOGOR (LLSH 7 5) (LRSH CHARCODE 12))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 2097152) THEN (* ; "x200000") (\BOUT STRM (LOGOR (LLSH 15 4) (LRSH CHARCODE 18))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 12 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE]) (UTF8.READCCODE [LAMBDA (FILE) (* ; "Edited 25-Apr-2018 17:23 by rmk:") (LET ((STRM (\GETSTREAM FILE 'INPUT)) BYTE1 BYTE2 BYTE3 BYTE4) (SETQ BYTE1 (\BIN STRM)) (* ;; "Distinguish on header byte, extract number of bytes so we don't read too far") (IF (ILESSP BYTE1 128) THEN (* ;; "Test first: Ascii is the common case") BYTE1 ELSEIF (IGEQ BYTE1 (LLSH 15 4)) THEN (* ; "4 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STRM)) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (SETQ BYTE4 (\BIN STRM)) (CL:WHEN (ILESSP BYTE4 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4))) (LOGOR (LLSH (LOADBYTE BYTE1 0 3) 18) (LLSH (LOADBYTE BYTE2 0 6) 12) (LLSH (LOADBYTE BYTE3 0 6) 6) (LOADBYTE BYTE4 0 6)) ELSEIF (IGEQ BYTE1 (LLSH 7 5)) THEN (* ; "3 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STRM)) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (LOGOR (LLSH (LOADBYTE BYTE1 0 4) 12) (LLSH (LOADBYTE BYTE2 0 6) 6) (LOADBYTE BYTE3 0 6)) ELSE (* ; "Must be 2 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (LOGOR (LLSH (LOADBYTE BYTE1 0 5) 6) (LOADBYTE BYTE2 0 6]) ) (* ;; "To read/access code translation tables") (DEFINEQ (FILETOCODETABLE [LAMBDA (FILE) (* ; "Edited 28-Apr-2018 16:07 by rmk:") (* rmk%: "20-Dec-87 10:08") (* ;; "Returns a (system-internal) arrayblock holding the contents of FILE.") (RESETLST (LET (LENGTH BLOCK STREAM) (CL:UNLESS (AND (STREAMP FILE) (SETQ STREAM (GETSTREAM FILE 'INPUT T))) [RESETSAVE [SETQ STREAM (OPENSTREAM FILE 'INPUT 'OLD '((SEQUENTIAL T) (TYPE BINARY] '(PROGN (CLOSEF? OLDVALUE]) (* ;; "Blocks are allocated in 4-byte units") (SETQ BLOCK (\ALLOCBLOCK (LRSH LENGTH 2))) (\BINS STREAM BLOCK 0 LENGTH) BLOCK))]) (CODECONVERT [LAMBDA (TABLE CODE) (* ; "Edited 28-Apr-2018 16:01 by rmk:") (* ;;  "Get the CODEth value from the arrayblock TABLE. CODE is a 16-bit index, 16 bits are returned.") (\GETBASE TABLE CODE]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILESLOAD (SYSLOAD) UNIXCOMM) (INSTALL-CLIPBOARD) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS CLIPBOARD COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1323 6343 (INSTALL-CLIPBOARD 1333 . 2706) (GETCLIPBOARD 2708 . 3192) (PUTCLIPBOARD 3194 . 3706) (PASTEFROMCLIPBOARD 3708 . 4325) (TEDIT.COPYTOCLIPBOARD 4327 . 4608) (SEDIT.COPYTOCLIPBOARD 4610 . 5918) (LISPINTERRUPTS.PASTE 5920 . 6341)) (6344 10759 (UTF8.PRINTCCODE 6354 . 8236) ( UTF8.READCCODE 8238 . 10757)) (10816 11984 (FILETOCODETABLE 10826 . 11711) (CODECONVERT 11713 . 11982) )))) STOP \ No newline at end of file diff --git a/library/CLIPBOARD.~22~ b/library/CLIPBOARD.~22~ deleted file mode 100644 index 04ed7e7f..00000000 --- a/library/CLIPBOARD.~22~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 5-May-2018 09:46:37"  {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;22 12280 changes to%: (FNS SEDIT.COPYTOCLIPBOARD) previous date%: "28-Apr-2018 16:07:41" {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;21) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD TEDIT.COPYTOCLIPBOARD SEDIT.COPYTOCLIPBOARD LISPINTERRUPTS.PASTE) (FNS UTF8.PRINTCCODE UTF8.READCCODE) (* ;; "To read/access code translation tables") (FNS FILETOCODETABLE CODECONVERT) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD) UNIXCOMM) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ; "Enable copy and paste") (DEFINEQ (INSTALL-CLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 23:00 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.PASTE) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.ORIG) (MOVD 'LISPINTERRUPTS.PASTE 'LISPINTERRUPTS)) (INTERRUPTCHAR (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (INTERRUPTCHAR (CHARCODE "1,V") '(PASTEFROMCLIPBOARD)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT") (* ;; "Paste") (TEDIT.SETFUNCTION (CHARCODE "1,v") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,V") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (* ;; "Copy") (TEDIT.SETFUNCTION (CHARCODE "1,c") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,C") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ;  "SEDIT copy: INTERRUPTCHAR does paste") (SEDIT:ADD-COMMAND "1,c" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:ADD-COMMAND "1,C" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:RESET-COMMANDS))]) (GETCLIPBOARD [LAMBDA NIL (* ; "Edited 25-Apr-2018 16:56 by rmk:") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbpaste")) [SETFILEINFO s 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (RETFROM (FUNCTION UTF8.READCCODE) NIL] (CONCATCODES (BIND C WHILE (SETQ C (UTF8.READCCODE s)) COLLECT C]) (PUTCLIPBOARD [CL:LAMBDA (STRING) (* ; "Edited 25-Apr-2018 16:49 by rmk:") (* ;; "Clipboard is UTF8") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbcopy")) (FOR I FROM 1 TO (NCHARS STRING) DO (UTF8.PRINTCCODE (NTHCHARCODE STRING I) s]) (PASTEFROMCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 13:56 by rmk:") (* ; "Edited 17-Apr-2018 23:11 by rmk:") (* ;;  "Should be able to just call COPYINSERT, but the default BKSYSBUF puts in string qujotes ") (LET ((STR (GETCLIPBOARD))) (IF (WINDOWPROP (PROCESS.WINDOW (TTY.PROCESS)) 'COPYINSERTFN) THEN (COPYINSERT STR) ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C]) (TEDIT.COPYTOCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM]) (SEDIT.COPYTOCLIPBOARD [LAMBDA (CONTEXT) (* ; "Edited 5-May-2018 09:43 by rmk:") (* ; "Edited 24-Apr-2018 20:39 by rmk:") (* ; "Edited 24-Apr-2018 20:33 by rmk:") (* ; "Edited 23-Apr-2018 18:19 by rmk:") (LET (SEL SELTYPE STRING) (* ;; "SEL could be a list of several elements, or a structure, depending on SELTYPE. ") (CL:MULTIPLE-VALUE-SETQ (SEL SELTYPE) (SEDIT:GET-SELECTION CONTEXT)) (* ;; "SELTYPE=NIL means not a valid selection, and SEL is NIL. Non-NIL values are :SUB-LIST, :CHARACTERS, and T") (IF SELTYPE THEN (SETQ STRING (MKSTRING SEL T)) (* ; " Readtable of caller?") (CL:WHEN (OR (EQ SELTYPE :CHARACTERS) (AND (EQ SELTYPE :SUB-LIST) (LISTP SEL))) (GNC STRING) (* ;  "Peel off outer parens for structures or quotes for atom/string characters") (GLC STRING)) (PUTCLIPBOARD STRING))) T]) (LISPINTERRUPTS.PASTE [LAMBDA NIL (* ; "Edited 18-Apr-2018 22:59 by rmk:") (* ;; "So paste interrupts will be installed in every process") (APPEND [LIST (LIST (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (LIST (CHARCODE "1,V") '(PASTEFROMCLIPBOARD] (LISPINTERRUPTS.ORIG]) ) (DEFINEQ (UTF8.PRINTCCODE [LAMBDA (CHARCODE FILE) (* ; "Edited 25-Apr-2018 17:56 by rmk:") (* ;; "PRINT UTF8 sequence for CHARACODE. Doesn't do XNS to Unicode character conversion, just does the transport encoding.") (LET [(STRM (\GETSTREAM FILE 'OUTPUT] (* ; "Output raw bytes") (IF (ILESSP CHARCODE 128) THEN (\BOUT STRM CHARCODE) ELSEIF (ILESSP CHARCODE 2048) THEN (* ; "x800") (\BOUT STRM (LOGOR (LLSH 3 6) (LRSH CHARCODE 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 65536) THEN (* ; "x10000") (\BOUT STRM (LOGOR (LLSH 7 5) (LRSH CHARCODE 12))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 2097152) THEN (* ; "x200000") (\BOUT STRM (LOGOR (LLSH 15 4) (LRSH CHARCODE 18))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 12 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE]) (UTF8.READCCODE [LAMBDA (FILE) (* ; "Edited 25-Apr-2018 17:23 by rmk:") (LET ((STRM (\GETSTREAM FILE 'INPUT)) BYTE1 BYTE2 BYTE3 BYTE4) (SETQ BYTE1 (\BIN STRM)) (* ;; "Distinguish on header byte, extract number of bytes so we don't read too far") (IF (ILESSP BYTE1 128) THEN (* ;; "Test first: Ascii is the common case") BYTE1 ELSEIF (IGEQ BYTE1 (LLSH 15 4)) THEN (* ; "4 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STRM)) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (SETQ BYTE4 (\BIN STRM)) (CL:WHEN (ILESSP BYTE4 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4))) (LOGOR (LLSH (LOADBYTE BYTE1 0 3) 18) (LLSH (LOADBYTE BYTE2 0 6) 12) (LLSH (LOADBYTE BYTE3 0 6) 6) (LOADBYTE BYTE4 0 6)) ELSEIF (IGEQ BYTE1 (LLSH 7 5)) THEN (* ; "3 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STRM)) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (LOGOR (LLSH (LOADBYTE BYTE1 0 4) 12) (LLSH (LOADBYTE BYTE2 0 6) 6) (LOADBYTE BYTE3 0 6)) ELSE (* ; "Must be 2 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (LOGOR (LLSH (LOADBYTE BYTE1 0 5) 6) (LOADBYTE BYTE2 0 6]) ) (* ;; "To read/access code translation tables") (DEFINEQ (FILETOCODETABLE [LAMBDA (FILE) (* ; "Edited 28-Apr-2018 16:07 by rmk:") (* rmk%: "20-Dec-87 10:08") (* ;; "Returns a (system-internal) arrayblock holding the contents of FILE.") (RESETLST (LET (LENGTH BLOCK STREAM) (CL:UNLESS (AND (STREAMP FILE) (SETQ STREAM (GETSTREAM FILE 'INPUT T))) [RESETSAVE [SETQ STREAM (OPENSTREAM FILE 'INPUT 'OLD '((SEQUENTIAL T) (TYPE BINARY] '(PROGN (CLOSEF? OLDVALUE]) (* ;; "Blocks are allocated in 4-byte units") (SETQ BLOCK (\ALLOCBLOCK (LRSH LENGTH 2))) (\BINS STREAM BLOCK 0 LENGTH) BLOCK))]) (CODECONVERT [LAMBDA (TABLE CODE) (* ; "Edited 28-Apr-2018 16:01 by rmk:") (* ;;  "Get the CODEth value from the arrayblock TABLE. CODE is a 16-bit index, 16 bits are returned.") (\GETBASE TABLE CODE]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILESLOAD (SYSLOAD) UNIXCOMM) (INSTALL-CLIPBOARD) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS CLIPBOARD COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1259 6345 (INSTALL-CLIPBOARD 1269 . 2642) (GETCLIPBOARD 2644 . 3128) (PUTCLIPBOARD 3130 . 3642) (PASTEFROMCLIPBOARD 3644 . 4261) (TEDIT.COPYTOCLIPBOARD 4263 . 4544) (SEDIT.COPYTOCLIPBOARD 4546 . 5920) (LISPINTERRUPTS.PASTE 5922 . 6343)) (6346 10761 (UTF8.PRINTCCODE 6356 . 8238) ( UTF8.READCCODE 8240 . 10759)) (10818 11986 (FILETOCODETABLE 10828 . 11713) (CODECONVERT 11715 . 11984) )))) STOP \ No newline at end of file diff --git a/library/CLIPBOARD.~33~ b/library/CLIPBOARD.~33~ deleted file mode 100644 index 2ada3b0d..00000000 --- a/library/CLIPBOARD.~33~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 3-Feb-2020 10:08:32"  {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;33 21122 changes to%: (FNS PUTCLIPBOARD UTF8.PRINTCCODE MAKECHARCODEMAPS GETCLIPBOARD UTF8.READCCODE) (VARS CLIPBOARDCOMS) previous date%: " 1-Feb-2020 18:01:03" {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;32) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD TEDIT.COPYTOCLIPBOARD SEDIT.COPYTOCLIPBOARD LISPINTERRUPTS.PASTE) (FNS UTF8.PRINTCCODE UTF8.READCCODE) (COMS (* ;; "To read/access code translation tables") (FNS FILETOCODETABLE CODECONVERT) (FNS MAKECHARCODEMAPS CBMAPCCODE) (GLOBALVARS XEROXRENDERING2UNICODEMAP UNICODE2XEROXRENDERINGMAP) (VARS CBUNICODETOXEROXRENDERING) (P (MAKECHARCODEMAPS))) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD) UNIXCOMM) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ; "Enable copy and paste") (DEFINEQ (INSTALL-CLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 23:00 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.PASTE) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.ORIG) (MOVD 'LISPINTERRUPTS.PASTE 'LISPINTERRUPTS)) (INTERRUPTCHAR (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (INTERRUPTCHAR (CHARCODE "1,V") '(PASTEFROMCLIPBOARD)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT") (* ;; "Paste") (TEDIT.SETFUNCTION (CHARCODE "1,v") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,V") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (* ;; "Copy") (TEDIT.SETFUNCTION (CHARCODE "1,c") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,C") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ;  "SEDIT copy: INTERRUPTCHAR does paste") (SEDIT:ADD-COMMAND "1,c" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:ADD-COMMAND "1,C" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:RESET-COMMANDS))]) (GETCLIPBOARD [LAMBDA NIL (* ; "Edited 3-Feb-2020 10:07 by rmk:") (* ; "Edited 25-Apr-2018 16:56 by rmk:") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbpaste")) [SETFILEINFO s 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (RETFROM (FUNCTION UTF8.READCCODE) NIL] (CONCATCODES (BIND C WHILE (SETQ C (UTF8.READCCODE s)) COLLECT (CBMAPCCODE UNICODE2XEROXRENDERINGMAP C]) (PUTCLIPBOARD [CL:LAMBDA (STRING) (* ; "Edited 3-Feb-2020 10:01 by rmk:") (* ; "Edited 25-Apr-2018 16:49 by rmk:") (* ;; "Clipboard is UNICODE and UTF8") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbcopy")) (FOR I FROM 1 TO (NCHARS STRING) DO (UTF8.PRINTCCODE (CBMAPCCODE XEROXRENDERING2UNICODEMAP (NTHCHARCODE STRING I)) s]) (PASTEFROMCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 13:56 by rmk:") (* ; "Edited 17-Apr-2018 23:11 by rmk:") (* ;;  "Should be able to just call COPYINSERT, but the default BKSYSBUF puts in string qujotes ") (LET ((STR (GETCLIPBOARD))) (IF (WINDOWPROP (PROCESS.WINDOW (TTY.PROCESS)) 'COPYINSERTFN) THEN (COPYINSERT STR) ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C]) (TEDIT.COPYTOCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM]) (SEDIT.COPYTOCLIPBOARD [LAMBDA (CONTEXT) (* ; "Edited 5-May-2018 09:43 by rmk:") (* ; "Edited 24-Apr-2018 20:39 by rmk:") (* ; "Edited 24-Apr-2018 20:33 by rmk:") (* ; "Edited 23-Apr-2018 18:19 by rmk:") (LET (SEL SELTYPE STRING) (* ;; "SEL could be a list of several elements, or a structure, depending on SELTYPE. ") (CL:MULTIPLE-VALUE-SETQ (SEL SELTYPE) (SEDIT:GET-SELECTION CONTEXT)) (* ;; "SELTYPE=NIL means not a valid selection, and SEL is NIL. Non-NIL values are :SUB-LIST, :CHARACTERS, and T") (IF SELTYPE THEN (SETQ STRING (MKSTRING SEL T)) (* ; " Readtable of caller?") (CL:WHEN (OR (EQ SELTYPE :CHARACTERS) (AND (EQ SELTYPE :SUB-LIST) (LISTP SEL))) (GNC STRING) (* ;  "Peel off outer parens for structures or quotes for atom/string characters") (GLC STRING)) (PUTCLIPBOARD STRING))) T]) (LISPINTERRUPTS.PASTE [LAMBDA NIL (* ; "Edited 18-Apr-2018 22:59 by rmk:") (* ;; "So paste interrupts will be installed in every process") (APPEND [LIST (LIST (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (LIST (CHARCODE "1,V") '(PASTEFROMCLIPBOARD] (LISPINTERRUPTS.ORIG]) ) (DEFINEQ (UTF8.PRINTCCODE [LAMBDA (CHARCODE FILE) (* ; "Edited 3-Feb-2020 10:01 by rmk:") (* ; "Edited 30-Jan-2020 23:08 by rmk:") (* ;; "PRINT UTF8 sequence for CHARCODE. .") (LET [(STRM (\GETSTREAM FILE 'OUTPUT] (* ; "Output raw bytes") (IF (ILESSP CHARCODE 128) THEN (\BOUT STRM CHARCODE) ELSEIF (ILESSP CHARCODE 2048) THEN (* ; "x800") (\BOUT STRM (LOGOR (LLSH 3 6) (LRSH CHARCODE 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 65536) THEN (* ; "x10000") (\BOUT STRM (LOGOR (LLSH 7 5) (LRSH CHARCODE 12))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 2097152) THEN (* ; "x200000") (\BOUT STRM (LOGOR (LLSH 15 4) (LRSH CHARCODE 18))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 12 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE]) (UTF8.READCCODE [LAMBDA (FILE) (* ; "Edited 3-Feb-2020 10:08 by rmk:") (* ; "Edited 30-Jan-2020 23:08 by rmk:") (LET ((STRM (\GETSTREAM FILE 'INPUT)) BYTE1 BYTE2 BYTE3 BYTE4) (SETQ BYTE1 (\BIN STRM)) (* ;; "Distinguish on header byte, extract number of bytes so we don't read too far") (IF (ILESSP BYTE1 128) THEN (* ;; "Test first: Ascii is the common case") BYTE1 ELSEIF (IGEQ BYTE1 (LLSH 15 4)) THEN (* ; "4 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STRM)) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (SETQ BYTE4 (\BIN STRM)) (CL:WHEN (ILESSP BYTE4 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4))) (LOGOR (LLSH (LOADBYTE BYTE1 0 3) 18) (LLSH (LOADBYTE BYTE2 0 6) 12) (LLSH (LOADBYTE BYTE3 0 6) 6) (LOADBYTE BYTE4 0 6)) ELSEIF (IGEQ BYTE1 (LLSH 7 5)) THEN (* ; "3 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STRM)) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (LOGOR (LLSH (LOADBYTE BYTE1 0 4) 12) (LLSH (LOADBYTE BYTE2 0 6) 6) (LOADBYTE BYTE3 0 6)) ELSE (* ; "Must be 2 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (LOGOR (LLSH (LOADBYTE BYTE1 0 5) 6) (LOADBYTE BYTE2 0 6]) ) (* ;; "To read/access code translation tables") (DEFINEQ (FILETOCODETABLE [LAMBDA (FILE) (* ; "Edited 28-Apr-2018 16:07 by rmk:") (* rmk%: "20-Dec-87 10:08") (* ;; "Returns a (system-internal) arrayblock holding the contents of FILE.") (RESETLST (LET (LENGTH BLOCK STREAM) (CL:UNLESS (AND (STREAMP FILE) (SETQ STREAM (GETSTREAM FILE 'INPUT T))) [RESETSAVE [SETQ STREAM (OPENSTREAM FILE 'INPUT 'OLD '((SEQUENTIAL T) (TYPE BINARY] '(PROGN (CLOSEF? OLDVALUE]) (* ;; "Blocks are allocated in 4-byte units") (SETQ BLOCK (\ALLOCBLOCK (LRSH LENGTH 2))) (\BINS STREAM BLOCK 0 LENGTH) BLOCK))]) (CODECONVERT [LAMBDA (TABLE CODE) (* ; "Edited 28-Apr-2018 16:01 by rmk:") (* ;;  "Get the CODEth value from the arrayblock TABLE. CODE is a 16-bit index, 16 bits are returned.") (\GETBASE TABLE CODE]) ) (DEFINEQ (MAKECHARCODEMAPS [LAMBDA NIL (* ; "Edited 3-Feb-2020 10:03 by rmk:") (* ; "Edited 1-Feb-2020 17:45 by rmk:") (* ; "Edited 30-Jan-2020 23:03 by rmk:") (* ;; "Clipboard is UNICODE. Uses an array for character set 0 and for any other highly populated segment, ALIST for relatively unpopulated ones.") (* ;; "Charset 0 is special also because it contains most input characters in both directions.") (* ;; "It sets TOCLIPBOARDMAP and FROMCLIPBOARDMAP each to a pair (array . list)") (LET ((TOCLIPBOARDARRAY (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FROMCLIPBOARDARRAY (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (TOCLIPBOARDLIST NIL) (FROMCLIPBOARDLIST NIL)) [FOR C CSETLIST IN CBUNICODETOXEROXRENDERING DO (IF (ILESSP (CADR C) 256) THEN (CL:SETF (CL:SVREF TOCLIPBOARDARRAY (CADR C)) (CAR C)) ELSE (PUSH [CDR (OR (ASSOC (LRSH (CADR C) 8) CSETLIST) (CAR (PUSH CSETLIST (CONS (LRSH (CADR C) 8] C)) FINALLY (SETQ TOCLIPBOARDLIST (FOR CS CSA IN CSETLIST COLLECT (CONS (CAR CS) (IF (IGREATERP (LENGTH (CDR CS)) 20) THEN (SETQ CSA (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FOR PAIR IN (CDR CS) DO (CL:SETF (CL:SVREF CSA (LOGAND (CADR PAIR) 255)) (CAR PAIR))) CSA ELSE (FOR PAIR IN (CDR CS) COLLECT (CONS (CADR PAIR) (CAR PAIR] [FOR C CSETLIST IN CBUNICODETOXEROXRENDERING DO (IF (ILESSP (CAR C) 256) THEN (CL:SETF (CL:SVREF FROMCLIPBOARDARRAY (CAR C)) (CADR C)) ELSE (PUSH [CDR (OR (ASSOC (LRSH (CAR C) 8) CSETLIST) (CAR (PUSH CSETLIST (CONS (LRSH (CAR C) 8] C)) FINALLY (SETQ FROMCLIPBOARDLIST (FOR CS CSA IN CSETLIST COLLECT (CONS (CAR CS) (IF (IGREATERP (LENGTH (CDR CS)) 20) THEN (SETQ CSA (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FOR PAIR IN (CDR CS) DO (CL:SETF (CL:SVREF CSA (LOGAND (CAR PAIR) 255)) (CADR PAIR))) CSA ELSE (FOR PAIR IN (CDR CS) COLLECT (CONS (CAR PAIR) (CADR PAIR] (SETQ XEROXRENDERING2UNICODEMAP (CONS TOCLIPBOARDARRAY TOCLIPBOARDLIST)) (SETQ UNICODE2XEROXRENDERINGMAP (CONS FROMCLIPBOARDARRAY FROMCLIPBOARDLIST]) (CBMAPCCODE [LAMBDA (CHARMAP CODE) (* ; "Edited 1-Feb-2020 17:49 by rmk:") (* ; "Edited 30-Jan-2020 22:47 by rmk:") (OR [IF (ILESSP CODE 256) THEN (CL:SVREF (CAR CHARMAP) CODE) ELSE (LET [(CS (CDR (ASSOC (LRSH CODE 8) (CDR CHARMAP] (CL:WHEN CS (IF (LISTP CS) THEN (CDR (ASSOC CODE CS)) ELSE (CL:SVREF CS (LOGAND CODE 255))))] CODE]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS XEROXRENDERING2UNICODEMAP UNICODE2XEROXRENDERINGMAP) ) (RPAQQ CBUNICODETOXEROXRENDERING ((146 39) (160 61217) (166 61291) (168 8994) (169 211) (170 227) (172 61290) (173 61219) (174 210) (175 9086) (180 39) (184 203) (185 209) (186 235) (192 61729) (193 61730) (194 61731) (195 61732) (196 61735) (197 61736) (198 225) (199 61741) (200 61744) (201 61745) (202 61746) (203 61749) (204 61758) (205 61759) (206 61760) (207 61764) (208 226) (209 61772) (210 61775) (211 61776) (212 61777) (213 61778) (214 61780) (215 180) (216 233) (217 61791) (218 61792) (219 61793) (220 61797) (221 61803) (222 236) (223 251) (224 61857) (225 61858) (226 61859) (227 61860) (228 61863) (229 61864) (230 241) (231 61869) (232 61872) (233 61873) (234 61874) (235 61877) (236 61886) (237 61887) (238 61888) (239 61892) (240 243) (241 61900) (242 61903) (243 61904) (244 61905) (245 61906) (246 61908) (247 184) (248 249) (249 61919) (250 61920) (251 61921) (252 61925) (253 61931) (254 252) (255 61933) (376 61805) (8594 174) (8592 172) (8593 173) (8595 175) (8712 61258) (8713 61259) (10 13))) (MAKECHARCODEMAPS) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILESLOAD (SYSLOAD) UNIXCOMM) (INSTALL-CLIPBOARD) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD TEDIT.COPYTOCLIPBOARD SEDIT.COPYTOCLIPBOARD LISPINTERRUPTS.PASTE) (FNS UTF8.PRINTCCODE UTF8.READCCODE) (COMS (* ;; "To read/access code translation tables") (FNS FILETOCODETABLE CODECONVERT) (FNS MAKECHARCODEMAPS CBMAPCCODE) (GLOBALVARS XEROXRENDERING2UNICODEMAP UNICODE2XEROXRENDERINGMAP) (VARS CBUNICODETOXEROXRENDERING) (P (MAKECHARCODEMAPS))) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD) UNIXCOMM) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA PUTCLIPBOARD]) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA PUTCLIPBOARD) ) (PUTPROPS CLIPBOARD COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1582 6951 (INSTALL-CLIPBOARD 1592 . 2965) (GETCLIPBOARD 2967 . 3629) (PUTCLIPBOARD 3631 . 4248) (PASTEFROMCLIPBOARD 4250 . 4867) (TEDIT.COPYTOCLIPBOARD 4869 . 5150) (SEDIT.COPYTOCLIPBOARD 5152 . 6526) (LISPINTERRUPTS.PASTE 6528 . 6949)) (6952 11504 (UTF8.PRINTCCODE 6962 . 8872) ( UTF8.READCCODE 8874 . 11502)) (11561 12729 (FILETOCODETABLE 11571 . 12456) (CODECONVERT 12458 . 12727) ) (12730 17725 (MAKECHARCODEMAPS 12740 . 17034) (CBMAPCCODE 17036 . 17723))))) STOP \ No newline at end of file diff --git a/library/CLIPBOARD.~37~ b/library/CLIPBOARD.~37~ deleted file mode 100644 index 7b0728d0..00000000 --- a/library/CLIPBOARD.~37~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "19-Apr-2020 12:18:20"  {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;37 21262 changes to%: (VARS CLIPBOARDCOMS CBUNICODETOXEROXRENDERING) (FNS INSTALL-CLIPBOARD TEDIT.EXTRACTTOCLIPBOARD MAKECHARCODEMAPS) previous date%: " 3-Feb-2020 10:08:32" {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;33) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD TEDIT.COPYTOCLIPBOARD TEDIT.EXTRACTTOCLIPBOARD SEDIT.COPYTOCLIPBOARD LISPINTERRUPTS.PASTE) (FNS UTF8.PRINTCCODE UTF8.READCCODE) (COMS (* ;; "To read/access code translation tables") (FNS FILETOCODETABLE CODECONVERT) (FNS MAKECHARCODEMAPS CBMAPCCODE) (GLOBALVARS XEROXRENDERING2UNICODEMAP UNICODE2XEROXRENDERINGMAP) (VARS CBUNICODETOXEROXRENDERING) (ALISTS (CHARACTERNAMES RSQ LSQ LDQ RDQ NEQ)) (P (MAKECHARCODEMAPS))) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD) UNIXCOMM) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ; "Enable copy and paste") (DEFINEQ (INSTALL-CLIPBOARD [LAMBDA NIL (* ; "Edited 19-Apr-2020 12:15 by rmk:") (* ; "Edited 18-Apr-2018 23:00 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.PASTE) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.ORIG) (MOVD 'LISPINTERRUPTS.PASTE 'LISPINTERRUPTS)) (INTERRUPTCHAR (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (INTERRUPTCHAR (CHARCODE "1,V") '(PASTEFROMCLIPBOARD)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT") (* ;; "Paste") (TEDIT.SETFUNCTION (CHARCODE "1,v") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,V") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (* ;; "Copy") (TEDIT.SETFUNCTION (CHARCODE "1,c") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,C") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,X") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,x") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ;  "SEDIT copy: INTERRUPTCHAR does paste") (SEDIT:ADD-COMMAND "1,c" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:ADD-COMMAND "1,C" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:RESET-COMMANDS))]) (GETCLIPBOARD [LAMBDA NIL (* ; "Edited 3-Feb-2020 10:07 by rmk:") (* ; "Edited 25-Apr-2018 16:56 by rmk:") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbpaste")) [SETFILEINFO s 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (RETFROM (FUNCTION UTF8.READCCODE) NIL] (CONCATCODES (BIND C WHILE (SETQ C (UTF8.READCCODE s)) COLLECT (CBMAPCCODE UNICODE2XEROXRENDERINGMAP C]) (PUTCLIPBOARD [CL:LAMBDA (STRING) (* ; "Edited 3-Feb-2020 10:01 by rmk:") (* ; "Edited 25-Apr-2018 16:49 by rmk:") (* ;; "Clipboard is UNICODE and UTF8") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbcopy")) (FOR I FROM 1 TO (NCHARS STRING) DO (UTF8.PRINTCCODE (CBMAPCCODE XEROXRENDERING2UNICODEMAP (NTHCHARCODE STRING I)) s]) (PASTEFROMCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 13:56 by rmk:") (* ; "Edited 17-Apr-2018 23:11 by rmk:") (* ;;  "Should be able to just call COPYINSERT, but the default BKSYSBUF puts in string qujotes ") (LET ((STR (GETCLIPBOARD))) (IF (WINDOWPROP (PROCESS.WINDOW (TTY.PROCESS)) 'COPYINSERTFN) THEN (COPYINSERT STR) ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C]) (TEDIT.COPYTOCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM]) (TEDIT.EXTRACTTOCLIPBOARD [LAMBDA NIL (* ; "Edited 19-Apr-2020 12:17 by rmk:") (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM)) (TEDIT.DELETE TEXTSTREAM (TEDIT.GETSEL TEXTSTREAM]) (SEDIT.COPYTOCLIPBOARD [LAMBDA (CONTEXT) (* ; "Edited 5-May-2018 09:43 by rmk:") (* ; "Edited 24-Apr-2018 20:39 by rmk:") (* ; "Edited 24-Apr-2018 20:33 by rmk:") (* ; "Edited 23-Apr-2018 18:19 by rmk:") (LET (SEL SELTYPE STRING) (* ;; "SEL could be a list of several elements, or a structure, depending on SELTYPE. ") (CL:MULTIPLE-VALUE-SETQ (SEL SELTYPE) (SEDIT:GET-SELECTION CONTEXT)) (* ;; "SELTYPE=NIL means not a valid selection, and SEL is NIL. Non-NIL values are :SUB-LIST, :CHARACTERS, and T") (IF SELTYPE THEN (SETQ STRING (MKSTRING SEL T)) (* ; " Readtable of caller?") (CL:WHEN (OR (EQ SELTYPE :CHARACTERS) (AND (EQ SELTYPE :SUB-LIST) (LISTP SEL))) (GNC STRING) (* ;  "Peel off outer parens for structures or quotes for atom/string characters") (GLC STRING)) (PUTCLIPBOARD STRING))) T]) (LISPINTERRUPTS.PASTE [LAMBDA NIL (* ; "Edited 18-Apr-2018 22:59 by rmk:") (* ;; "So paste interrupts will be installed in every process") (APPEND [LIST (LIST (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (LIST (CHARCODE "1,V") '(PASTEFROMCLIPBOARD] (LISPINTERRUPTS.ORIG]) ) (DEFINEQ (UTF8.PRINTCCODE [LAMBDA (CHARCODE FILE) (* ; "Edited 3-Feb-2020 10:01 by rmk:") (* ; "Edited 30-Jan-2020 23:08 by rmk:") (* ;; "PRINT UTF8 sequence for CHARCODE. .") (LET [(STRM (\GETSTREAM FILE 'OUTPUT] (* ; "Output raw bytes") (IF (ILESSP CHARCODE 128) THEN (\BOUT STRM CHARCODE) ELSEIF (ILESSP CHARCODE 2048) THEN (* ; "x800") (\BOUT STRM (LOGOR (LLSH 3 6) (LRSH CHARCODE 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 65536) THEN (* ; "x10000") (\BOUT STRM (LOGOR (LLSH 7 5) (LRSH CHARCODE 12))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 2097152) THEN (* ; "x200000") (\BOUT STRM (LOGOR (LLSH 15 4) (LRSH CHARCODE 18))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 12 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE]) (UTF8.READCCODE [LAMBDA (FILE) (* ; "Edited 3-Feb-2020 10:08 by rmk:") (* ; "Edited 30-Jan-2020 23:08 by rmk:") (LET ((STRM (\GETSTREAM FILE 'INPUT)) BYTE1 BYTE2 BYTE3 BYTE4) (SETQ BYTE1 (\BIN STRM)) (* ;; "Distinguish on header byte, extract number of bytes so we don't read too far") (IF (ILESSP BYTE1 128) THEN (* ;; "Test first: Ascii is the common case") BYTE1 ELSEIF (IGEQ BYTE1 (LLSH 15 4)) THEN (* ; "4 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STRM)) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (SETQ BYTE4 (\BIN STRM)) (CL:WHEN (ILESSP BYTE4 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4))) (LOGOR (LLSH (LOADBYTE BYTE1 0 3) 18) (LLSH (LOADBYTE BYTE2 0 6) 12) (LLSH (LOADBYTE BYTE3 0 6) 6) (LOADBYTE BYTE4 0 6)) ELSEIF (IGEQ BYTE1 (LLSH 7 5)) THEN (* ; "3 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STRM)) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (LOGOR (LLSH (LOADBYTE BYTE1 0 4) 12) (LLSH (LOADBYTE BYTE2 0 6) 6) (LOADBYTE BYTE3 0 6)) ELSE (* ; "Must be 2 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (LOGOR (LLSH (LOADBYTE BYTE1 0 5) 6) (LOADBYTE BYTE2 0 6]) ) (* ;; "To read/access code translation tables") (DEFINEQ (FILETOCODETABLE [LAMBDA (FILE) (* ; "Edited 28-Apr-2018 16:07 by rmk:") (* rmk%: "20-Dec-87 10:08") (* ;; "Returns a (system-internal) arrayblock holding the contents of FILE.") (RESETLST (LET (LENGTH BLOCK STREAM) (CL:UNLESS (AND (STREAMP FILE) (SETQ STREAM (GETSTREAM FILE 'INPUT T))) [RESETSAVE [SETQ STREAM (OPENSTREAM FILE 'INPUT 'OLD '((SEQUENTIAL T) (TYPE BINARY] '(PROGN (CLOSEF? OLDVALUE]) (* ;; "Blocks are allocated in 4-byte units") (SETQ BLOCK (\ALLOCBLOCK (LRSH LENGTH 2))) (\BINS STREAM BLOCK 0 LENGTH) BLOCK))]) (CODECONVERT [LAMBDA (TABLE CODE) (* ; "Edited 28-Apr-2018 16:01 by rmk:") (* ;;  "Get the CODEth value from the arrayblock TABLE. CODE is a 16-bit index, 16 bits are returned.") (\GETBASE TABLE CODE]) ) (DEFINEQ (MAKECHARCODEMAPS [LAMBDA NIL (* ; "Edited 19-Apr-2020 11:43 by rmk:") (* ; "Edited 3-Feb-2020 10:03 by rmk:") (* ; "Edited 1-Feb-2020 17:45 by rmk:") (* ; "Edited 30-Jan-2020 23:03 by rmk:") (* ;; "Clipboard is UNICODE. Uses an array for character set 0 and for any other highly populated segment, ALIST for relatively unpopulated ones.") (* ;; "Charset 0 is special also because it contains most input characters in both directions.") (* ;; "It sets TOCLIPBOARDMAP and FROMCLIPBOARDMAP each to a pair (array . list)") (LET ((TOCLIPBOARDARRAY (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FROMCLIPBOARDARRAY (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (TOCLIPBOARDLIST NIL) (FROMCLIPBOARDLIST NIL)) [FOR C XC CSETLIST IN CBUNICODETOXEROXRENDERING DO (SETQ XC (CADR C)) (CL:UNLESS (FIXP XC) (SETQ XC (CHARCODE.DECODE XC))) (IF (ILESSP XC 256) THEN (CL:SETF (CL:SVREF TOCLIPBOARDARRAY XC) (CAR C)) ELSE (PUSH [CDR (OR (ASSOC (LRSH XC 8) CSETLIST) (CAR (PUSH CSETLIST (CONS (LRSH XC 8] C)) FINALLY (SETQ TOCLIPBOARDLIST (FOR CS CSA IN CSETLIST COLLECT (CONS (CAR CS) (IF (IGREATERP (LENGTH (CDR CS)) 20) THEN (SETQ CSA (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FOR PAIR IN (CDR CS) DO (CL:SETF (CL:SVREF CSA (LOGAND (CADR PAIR) 255)) (CAR PAIR))) CSA ELSE (FOR PAIR IN (CDR CS) COLLECT (CONS (CADR PAIR) (CAR PAIR] [FOR C CSETLIST IN CBUNICODETOXEROXRENDERING DO (CL:UNLESS (FIXP (CADR C)) [SETQ C (LIST (CAR C) (CHARCODE.DECODE (CADR C]) (IF (ILESSP (CAR C) 256) THEN (CL:SETF (CL:SVREF FROMCLIPBOARDARRAY (CAR C)) (CADR C)) ELSE (PUSH [CDR (OR (ASSOC (LRSH (CAR C) 8) CSETLIST) (CAR (PUSH CSETLIST (CONS (LRSH (CAR C) 8] C)) FINALLY (SETQ FROMCLIPBOARDLIST (FOR CS CSA IN CSETLIST COLLECT (CONS (CAR CS) (IF (IGREATERP (LENGTH (CDR CS)) 20) THEN (SETQ CSA (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FOR PAIR IN (CDR CS) DO (CL:SETF (CL:SVREF CSA (LOGAND (CAR PAIR) 255)) (CADR PAIR))) CSA ELSE (FOR PAIR IN (CDR CS) COLLECT (CONS (CAR PAIR) (CADR PAIR] (SETQ XEROXRENDERING2UNICODEMAP (CONS TOCLIPBOARDARRAY TOCLIPBOARDLIST)) (SETQ UNICODE2XEROXRENDERINGMAP (CONS FROMCLIPBOARDARRAY FROMCLIPBOARDLIST]) (CBMAPCCODE [LAMBDA (CHARMAP CODE) (* ; "Edited 1-Feb-2020 17:49 by rmk:") (* ; "Edited 30-Jan-2020 22:47 by rmk:") (OR [IF (ILESSP CODE 256) THEN (CL:SVREF (CAR CHARMAP) CODE) ELSE (LET [(CS (CDR (ASSOC (LRSH CODE 8) (CDR CHARMAP] (CL:WHEN CS (IF (LISTP CS) THEN (CDR (ASSOC CODE CS)) ELSE (CL:SVREF CS (LOGAND CODE 255))))] CODE]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS XEROXRENDERING2UNICODEMAP UNICODE2XEROXRENDERINGMAP) ) (RPAQQ CBUNICODETOXEROXRENDERING ((8217 RSQ) (8216 LSQ) (8221 RDQ) (8220 LDQ) (8800 NEQ) (146 39) (160 61217) (166 61291) (168 8994) (169 211) (170 227) (172 61290) (173 61219) (174 210) (175 9086) (180 39) (184 203) (185 209) (186 235) (192 61729) (193 61730) (194 61731) (195 61732) (196 61735) (197 61736) (198 225) (199 61741) (200 61744) (201 61745) (202 61746) (203 61749) (204 61758) (205 61759) (206 61760) (207 61764) (208 226) (209 61772) (210 61775) (211 61776) (212 61777) (213 61778) (214 61780) (215 180) (216 233) (217 61791) (218 61792) (219 61793) (220 61797) (221 61803) (222 236) (223 251) (224 61857) (225 61858) (226 61859) (227 61860) (228 61863) (229 61864) (230 241) (231 61869) (232 61872) (233 61873) (234 61874) (235 61877) (236 61886) (237 61887) (238 61888) (239 61892) (240 243) (241 61900) (242 61903) (243 61904) (244 61905) (245 61906) (246 61908) (247 184) (248 249) (249 61919) (250 61920) (251 61921) (252 61925) (253 61931) (254 252) (255 61933) (376 61805) (8594 174) (8592 172) (8593 173) (8595 175) (8712 61258) (8713 61259) (10 13))) (ADDTOVAR CHARACTERNAMES (RSQ "0,271") (LSQ "0,251") (LDQ "0,252") (RDQ "0,272") (NEQ "041,142")) (MAKECHARCODEMAPS) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILESLOAD (SYSLOAD) UNIXCOMM) (INSTALL-CLIPBOARD) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS CLIPBOARD COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1679 7877 (INSTALL-CLIPBOARD 1689 . 3425) (GETCLIPBOARD 3427 . 4089) (PUTCLIPBOARD 4091 . 4708) (PASTEFROMCLIPBOARD 4710 . 5327) (TEDIT.COPYTOCLIPBOARD 5329 . 5610) ( TEDIT.EXTRACTTOCLIPBOARD 5612 . 6076) (SEDIT.COPYTOCLIPBOARD 6078 . 7452) (LISPINTERRUPTS.PASTE 7454 . 7875)) (7878 12430 (UTF8.PRINTCCODE 7888 . 9798) (UTF8.READCCODE 9800 . 12428)) (12487 13655 ( FILETOCODETABLE 12497 . 13382) (CODECONVERT 13384 . 13653)) (13656 18815 (MAKECHARCODEMAPS 13666 . 18124) (CBMAPCCODE 18126 . 18813))))) STOP \ No newline at end of file diff --git a/library/CLIPBOARD.~40~ b/library/CLIPBOARD.~40~ deleted file mode 100644 index b6c8b3d1..00000000 --- a/library/CLIPBOARD.~40~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 3-May-2020 17:34:19"  {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;40 21963 changes to%: (FNS INSTALL-CLIPBOARD TEDIT.SELECTALL) (VARS CLIPBOARDCOMS) previous date%: " 3-May-2020 17:33:15" {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;39) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD LISPINTERRUPTS.PASTE) (FNS UTF8.PRINTCCODE UTF8.READCCODE) (FNS TEDIT.COPYTOCLIPBOARD TEDIT.EXTRACTTOCLIPBOARD TEDIT.SELECTALL) (FNS SEDIT.COPYTOCLIPBOARD) (COMS (* ;; "To read/access code translation tables") (FNS FILETOCODETABLE CODECONVERT) (FNS MAKECHARCODEMAPS CBMAPCCODE) (GLOBALVARS XEROXRENDERING2UNICODEMAP UNICODE2XEROXRENDERINGMAP) (VARS CBUNICODETOXEROXRENDERING) (ALISTS (CHARACTERNAMES RSQ LSQ LDQ RDQ NEQ)) (P (MAKECHARCODEMAPS))) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD) UNIXCOMM) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ; "Enable copy and paste") (DEFINEQ (INSTALL-CLIPBOARD [LAMBDA NIL (* ; "Edited 3-May-2020 17:33 by rmk:") (* ; "Edited 19-Apr-2020 12:15 by rmk:") (* ; "Edited 18-Apr-2018 23:00 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.PASTE) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.ORIG) (MOVD 'LISPINTERRUPTS.PASTE 'LISPINTERRUPTS)) (INTERRUPTCHAR (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (INTERRUPTCHAR (CHARCODE "1,V") '(PASTEFROMCLIPBOARD)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT") (* ;; "Paste") (TEDIT.SETFUNCTION (CHARCODE "1,v") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,V") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (* ;; "Copy") (TEDIT.SETFUNCTION (CHARCODE "1,c") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,C") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,X") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,x") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE) (* ;; "All") (TEDIT.SETFUNCTION (CHARCODE "1,a") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,A") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ;  "SEDIT copy: INTERRUPTCHAR does paste") (SEDIT:ADD-COMMAND "1,c" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:ADD-COMMAND "1,C" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:RESET-COMMANDS))]) (GETCLIPBOARD [LAMBDA NIL (* ; "Edited 3-Feb-2020 10:07 by rmk:") (* ; "Edited 25-Apr-2018 16:56 by rmk:") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbpaste")) [SETFILEINFO s 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (RETFROM (FUNCTION UTF8.READCCODE) NIL] (CONCATCODES (BIND C WHILE (SETQ C (UTF8.READCCODE s)) COLLECT (CBMAPCCODE UNICODE2XEROXRENDERINGMAP C]) (PUTCLIPBOARD [CL:LAMBDA (STRING) (* ; "Edited 3-Feb-2020 10:01 by rmk:") (* ; "Edited 25-Apr-2018 16:49 by rmk:") (* ;; "Clipboard is UNICODE and UTF8") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbcopy")) (FOR I FROM 1 TO (NCHARS STRING) DO (UTF8.PRINTCCODE (CBMAPCCODE XEROXRENDERING2UNICODEMAP (NTHCHARCODE STRING I)) s]) (PASTEFROMCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 13:56 by rmk:") (* ; "Edited 17-Apr-2018 23:11 by rmk:") (* ;;  "Should be able to just call COPYINSERT, but the default BKSYSBUF puts in string qujotes ") (LET ((STR (GETCLIPBOARD))) (IF (WINDOWPROP (PROCESS.WINDOW (TTY.PROCESS)) 'COPYINSERTFN) THEN (COPYINSERT STR) ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C]) (LISPINTERRUPTS.PASTE [LAMBDA NIL (* ; "Edited 18-Apr-2018 22:59 by rmk:") (* ;; "So paste interrupts will be installed in every process") (APPEND [LIST (LIST (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (LIST (CHARCODE "1,V") '(PASTEFROMCLIPBOARD] (LISPINTERRUPTS.ORIG]) ) (DEFINEQ (UTF8.PRINTCCODE [LAMBDA (CHARCODE FILE) (* ; "Edited 3-Feb-2020 10:01 by rmk:") (* ; "Edited 30-Jan-2020 23:08 by rmk:") (* ;; "PRINT UTF8 sequence for CHARCODE. .") (LET [(STRM (\GETSTREAM FILE 'OUTPUT] (* ; "Output raw bytes") (IF (ILESSP CHARCODE 128) THEN (\BOUT STRM CHARCODE) ELSEIF (ILESSP CHARCODE 2048) THEN (* ; "x800") (\BOUT STRM (LOGOR (LLSH 3 6) (LRSH CHARCODE 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 65536) THEN (* ; "x10000") (\BOUT STRM (LOGOR (LLSH 7 5) (LRSH CHARCODE 12))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 2097152) THEN (* ; "x200000") (\BOUT STRM (LOGOR (LLSH 15 4) (LRSH CHARCODE 18))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 12 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE]) (UTF8.READCCODE [LAMBDA (FILE) (* ; "Edited 3-Feb-2020 10:08 by rmk:") (* ; "Edited 30-Jan-2020 23:08 by rmk:") (LET ((STRM (\GETSTREAM FILE 'INPUT)) BYTE1 BYTE2 BYTE3 BYTE4) (SETQ BYTE1 (\BIN STRM)) (* ;; "Distinguish on header byte, extract number of bytes so we don't read too far") (IF (ILESSP BYTE1 128) THEN (* ;; "Test first: Ascii is the common case") BYTE1 ELSEIF (IGEQ BYTE1 (LLSH 15 4)) THEN (* ; "4 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STRM)) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (SETQ BYTE4 (\BIN STRM)) (CL:WHEN (ILESSP BYTE4 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4))) (LOGOR (LLSH (LOADBYTE BYTE1 0 3) 18) (LLSH (LOADBYTE BYTE2 0 6) 12) (LLSH (LOADBYTE BYTE3 0 6) 6) (LOADBYTE BYTE4 0 6)) ELSEIF (IGEQ BYTE1 (LLSH 7 5)) THEN (* ; "3 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STRM)) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (LOGOR (LLSH (LOADBYTE BYTE1 0 4) 12) (LLSH (LOADBYTE BYTE2 0 6) 6) (LOADBYTE BYTE3 0 6)) ELSE (* ; "Must be 2 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (LOGOR (LLSH (LOADBYTE BYTE1 0 5) 6) (LOADBYTE BYTE2 0 6]) ) (DEFINEQ (TEDIT.COPYTOCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM]) (TEDIT.EXTRACTTOCLIPBOARD [LAMBDA NIL (* ; "Edited 19-Apr-2020 12:17 by rmk:") (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM)) (TEDIT.DELETE TEXTSTREAM (TEDIT.GETSEL TEXTSTREAM]) (TEDIT.SELECTALL [LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 3-May-2020 17:29 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (CL:WHEN TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch TEXTLEN of (TEXTOBJ TEXTSTREAM))) 'LEFT))]) ) (DEFINEQ (SEDIT.COPYTOCLIPBOARD [LAMBDA (CONTEXT) (* ; "Edited 5-May-2018 09:43 by rmk:") (* ; "Edited 24-Apr-2018 20:39 by rmk:") (* ; "Edited 24-Apr-2018 20:33 by rmk:") (* ; "Edited 23-Apr-2018 18:19 by rmk:") (LET (SEL SELTYPE STRING) (* ;; "SEL could be a list of several elements, or a structure, depending on SELTYPE. ") (CL:MULTIPLE-VALUE-SETQ (SEL SELTYPE) (SEDIT:GET-SELECTION CONTEXT)) (* ;; "SELTYPE=NIL means not a valid selection, and SEL is NIL. Non-NIL values are :SUB-LIST, :CHARACTERS, and T") (IF SELTYPE THEN (SETQ STRING (MKSTRING SEL T)) (* ; " Readtable of caller?") (CL:WHEN (OR (EQ SELTYPE :CHARACTERS) (AND (EQ SELTYPE :SUB-LIST) (LISTP SEL))) (GNC STRING) (* ;  "Peel off outer parens for structures or quotes for atom/string characters") (GLC STRING)) (PUTCLIPBOARD STRING))) T]) ) (* ;; "To read/access code translation tables") (DEFINEQ (FILETOCODETABLE [LAMBDA (FILE) (* ; "Edited 28-Apr-2018 16:07 by rmk:") (* rmk%: "20-Dec-87 10:08") (* ;; "Returns a (system-internal) arrayblock holding the contents of FILE.") (RESETLST (LET (LENGTH BLOCK STREAM) (CL:UNLESS (AND (STREAMP FILE) (SETQ STREAM (GETSTREAM FILE 'INPUT T))) [RESETSAVE [SETQ STREAM (OPENSTREAM FILE 'INPUT 'OLD '((SEQUENTIAL T) (TYPE BINARY] '(PROGN (CLOSEF? OLDVALUE]) (* ;; "Blocks are allocated in 4-byte units") (SETQ BLOCK (\ALLOCBLOCK (LRSH LENGTH 2))) (\BINS STREAM BLOCK 0 LENGTH) BLOCK))]) (CODECONVERT [LAMBDA (TABLE CODE) (* ; "Edited 28-Apr-2018 16:01 by rmk:") (* ;;  "Get the CODEth value from the arrayblock TABLE. CODE is a 16-bit index, 16 bits are returned.") (\GETBASE TABLE CODE]) ) (DEFINEQ (MAKECHARCODEMAPS [LAMBDA NIL (* ; "Edited 19-Apr-2020 11:43 by rmk:") (* ; "Edited 3-Feb-2020 10:03 by rmk:") (* ; "Edited 1-Feb-2020 17:45 by rmk:") (* ; "Edited 30-Jan-2020 23:03 by rmk:") (* ;; "Clipboard is UNICODE. Uses an array for character set 0 and for any other highly populated segment, ALIST for relatively unpopulated ones.") (* ;; "Charset 0 is special also because it contains most input characters in both directions.") (* ;; "It sets TOCLIPBOARDMAP and FROMCLIPBOARDMAP each to a pair (array . list)") (LET ((TOCLIPBOARDARRAY (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FROMCLIPBOARDARRAY (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (TOCLIPBOARDLIST NIL) (FROMCLIPBOARDLIST NIL)) [FOR C XC CSETLIST IN CBUNICODETOXEROXRENDERING DO (SETQ XC (CADR C)) (CL:UNLESS (FIXP XC) (SETQ XC (CHARCODE.DECODE XC))) (IF (ILESSP XC 256) THEN (CL:SETF (CL:SVREF TOCLIPBOARDARRAY XC) (CAR C)) ELSE (PUSH [CDR (OR (ASSOC (LRSH XC 8) CSETLIST) (CAR (PUSH CSETLIST (CONS (LRSH XC 8] C)) FINALLY (SETQ TOCLIPBOARDLIST (FOR CS CSA IN CSETLIST COLLECT (CONS (CAR CS) (IF (IGREATERP (LENGTH (CDR CS)) 20) THEN (SETQ CSA (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FOR PAIR IN (CDR CS) DO (CL:SETF (CL:SVREF CSA (LOGAND (CADR PAIR) 255)) (CAR PAIR))) CSA ELSE (FOR PAIR IN (CDR CS) COLLECT (CONS (CADR PAIR) (CAR PAIR] [FOR C CSETLIST IN CBUNICODETOXEROXRENDERING DO (CL:UNLESS (FIXP (CADR C)) [SETQ C (LIST (CAR C) (CHARCODE.DECODE (CADR C]) (IF (ILESSP (CAR C) 256) THEN (CL:SETF (CL:SVREF FROMCLIPBOARDARRAY (CAR C)) (CADR C)) ELSE (PUSH [CDR (OR (ASSOC (LRSH (CAR C) 8) CSETLIST) (CAR (PUSH CSETLIST (CONS (LRSH (CAR C) 8] C)) FINALLY (SETQ FROMCLIPBOARDLIST (FOR CS CSA IN CSETLIST COLLECT (CONS (CAR CS) (IF (IGREATERP (LENGTH (CDR CS)) 20) THEN (SETQ CSA (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FOR PAIR IN (CDR CS) DO (CL:SETF (CL:SVREF CSA (LOGAND (CAR PAIR) 255)) (CADR PAIR))) CSA ELSE (FOR PAIR IN (CDR CS) COLLECT (CONS (CAR PAIR) (CADR PAIR] (SETQ XEROXRENDERING2UNICODEMAP (CONS TOCLIPBOARDARRAY TOCLIPBOARDLIST)) (SETQ UNICODE2XEROXRENDERINGMAP (CONS FROMCLIPBOARDARRAY FROMCLIPBOARDLIST]) (CBMAPCCODE [LAMBDA (CHARMAP CODE) (* ; "Edited 1-Feb-2020 17:49 by rmk:") (* ; "Edited 30-Jan-2020 22:47 by rmk:") (OR [IF (ILESSP CODE 256) THEN (CL:SVREF (CAR CHARMAP) CODE) ELSE (LET [(CS (CDR (ASSOC (LRSH CODE 8) (CDR CHARMAP] (CL:WHEN CS (IF (LISTP CS) THEN (CDR (ASSOC CODE CS)) ELSE (CL:SVREF CS (LOGAND CODE 255))))] CODE]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS XEROXRENDERING2UNICODEMAP UNICODE2XEROXRENDERINGMAP) ) (RPAQQ CBUNICODETOXEROXRENDERING ((8217 RSQ) (8216 LSQ) (8221 RDQ) (8220 LDQ) (8800 NEQ) (146 39) (160 61217) (166 61291) (168 8994) (169 211) (170 227) (172 61290) (173 61219) (174 210) (175 9086) (180 39) (184 203) (185 209) (186 235) (192 61729) (193 61730) (194 61731) (195 61732) (196 61735) (197 61736) (198 225) (199 61741) (200 61744) (201 61745) (202 61746) (203 61749) (204 61758) (205 61759) (206 61760) (207 61764) (208 226) (209 61772) (210 61775) (211 61776) (212 61777) (213 61778) (214 61780) (215 180) (216 233) (217 61791) (218 61792) (219 61793) (220 61797) (221 61803) (222 236) (223 251) (224 61857) (225 61858) (226 61859) (227 61860) (228 61863) (229 61864) (230 241) (231 61869) (232 61872) (233 61873) (234 61874) (235 61877) (236 61886) (237 61887) (238 61888) (239 61892) (240 243) (241 61900) (242 61903) (243 61904) (244 61905) (245 61906) (246 61908) (247 184) (248 249) (249 61919) (250 61920) (251 61921) (252 61925) (253 61931) (254 252) (255 61933) (376 61805) (8594 174) (8592 172) (8593 173) (8595 175) (8712 61258) (8713 61259) (10 13))) (ADDTOVAR CHARACTERNAMES (RSQ "0,271") (LSQ "0,251") (LDQ "0,252") (RDQ "0,272") (NEQ "041,142")) (MAKECHARCODEMAPS) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILESLOAD (SYSLOAD) UNIXCOMM) (INSTALL-CLIPBOARD) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS CLIPBOARD COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1657 6102 (INSTALL-CLIPBOARD 1667 . 3775) (GETCLIPBOARD 3777 . 4439) (PUTCLIPBOARD 4441 . 5058) (PASTEFROMCLIPBOARD 5060 . 5677) (LISPINTERRUPTS.PASTE 5679 . 6100)) (6103 10655 ( UTF8.PRINTCCODE 6113 . 8023) (UTF8.READCCODE 8025 . 10653)) (10656 11744 (TEDIT.COPYTOCLIPBOARD 10666 . 10947) (TEDIT.EXTRACTTOCLIPBOARD 10949 . 11413) (TEDIT.SELECTALL 11415 . 11742)) (11745 13131 ( SEDIT.COPYTOCLIPBOARD 11755 . 13129)) (13188 14356 (FILETOCODETABLE 13198 . 14083) (CODECONVERT 14085 . 14354)) (14357 19516 (MAKECHARCODEMAPS 14367 . 18825) (CBMAPCCODE 18827 . 19514))))) STOP \ No newline at end of file diff --git a/library/CLIPBOARD.~41~ b/library/CLIPBOARD.~41~ deleted file mode 100644 index e2ba3c5a..00000000 --- a/library/CLIPBOARD.~41~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "24-Jun-2020 20:17:42"  {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;41 22191 changes to%: (FNS INSTALL-CLIPBOARD) previous date%: " 3-May-2020 17:34:19" {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;40) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD LISPINTERRUPTS.PASTE) (FNS UTF8.PRINTCCODE UTF8.READCCODE) (FNS TEDIT.COPYTOCLIPBOARD TEDIT.EXTRACTTOCLIPBOARD TEDIT.SELECTALL) (FNS SEDIT.COPYTOCLIPBOARD) (COMS (* ;; "To read/access code translation tables") (FNS FILETOCODETABLE CODECONVERT) (FNS MAKECHARCODEMAPS CBMAPCCODE) (GLOBALVARS XEROXRENDERING2UNICODEMAP UNICODE2XEROXRENDERINGMAP) (VARS CBUNICODETOXEROXRENDERING) (ALISTS (CHARACTERNAMES RSQ LSQ LDQ RDQ NEQ)) (P (MAKECHARCODEMAPS))) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD) UNIXCOMM) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ; "Enable copy and paste") (DEFINEQ (INSTALL-CLIPBOARD [LAMBDA NIL (* ; "Edited 24-Jun-2020 20:14 by rmk:") (* ; "Edited 19-Apr-2020 12:15 by rmk:") (* ; "Edited 18-Apr-2018 23:00 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.PASTE) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.ORIG) (MOVD 'LISPINTERRUPTS.PASTE 'LISPINTERRUPTS)) (INTERRUPTCHAR (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (INTERRUPTCHAR (CHARCODE "1,V") '(PASTEFROMCLIPBOARD)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT") (* ;; "Paste") (TEDIT.SETFUNCTION (CHARCODE "1,v") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,V") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (* ;; "Copy") (TEDIT.SETFUNCTION (CHARCODE "1,c") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,C") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (* ;; "Extract") (TEDIT.SETFUNCTION (CHARCODE "1,X") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,x") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE) (* ;; "All") (TEDIT.SETFUNCTION (CHARCODE "1,a") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,A") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (* ;; "Quit") (TEDIT.SETFUNCTION (CHARCODE "1,q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,Q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ;  "SEDIT copy: INTERRUPTCHAR does paste") (SEDIT:ADD-COMMAND "1,c" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:ADD-COMMAND "1,C" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:RESET-COMMANDS))]) (GETCLIPBOARD [LAMBDA NIL (* ; "Edited 3-Feb-2020 10:07 by rmk:") (* ; "Edited 25-Apr-2018 16:56 by rmk:") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbpaste")) [SETFILEINFO s 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (RETFROM (FUNCTION UTF8.READCCODE) NIL] (CONCATCODES (BIND C WHILE (SETQ C (UTF8.READCCODE s)) COLLECT (CBMAPCCODE UNICODE2XEROXRENDERINGMAP C]) (PUTCLIPBOARD [CL:LAMBDA (STRING) (* ; "Edited 3-Feb-2020 10:01 by rmk:") (* ; "Edited 25-Apr-2018 16:49 by rmk:") (* ;; "Clipboard is UNICODE and UTF8") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbcopy")) (FOR I FROM 1 TO (NCHARS STRING) DO (UTF8.PRINTCCODE (CBMAPCCODE XEROXRENDERING2UNICODEMAP (NTHCHARCODE STRING I)) s]) (PASTEFROMCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 13:56 by rmk:") (* ; "Edited 17-Apr-2018 23:11 by rmk:") (* ;;  "Should be able to just call COPYINSERT, but the default BKSYSBUF puts in string qujotes ") (LET ((STR (GETCLIPBOARD))) (IF (WINDOWPROP (PROCESS.WINDOW (TTY.PROCESS)) 'COPYINSERTFN) THEN (COPYINSERT STR) ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C]) (LISPINTERRUPTS.PASTE [LAMBDA NIL (* ; "Edited 18-Apr-2018 22:59 by rmk:") (* ;; "So paste interrupts will be installed in every process") (APPEND [LIST (LIST (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (LIST (CHARCODE "1,V") '(PASTEFROMCLIPBOARD] (LISPINTERRUPTS.ORIG]) ) (DEFINEQ (UTF8.PRINTCCODE [LAMBDA (CHARCODE FILE) (* ; "Edited 3-Feb-2020 10:01 by rmk:") (* ; "Edited 30-Jan-2020 23:08 by rmk:") (* ;; "PRINT UTF8 sequence for CHARCODE. .") (LET [(STRM (\GETSTREAM FILE 'OUTPUT] (* ; "Output raw bytes") (IF (ILESSP CHARCODE 128) THEN (\BOUT STRM CHARCODE) ELSEIF (ILESSP CHARCODE 2048) THEN (* ; "x800") (\BOUT STRM (LOGOR (LLSH 3 6) (LRSH CHARCODE 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 65536) THEN (* ; "x10000") (\BOUT STRM (LOGOR (LLSH 7 5) (LRSH CHARCODE 12))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 2097152) THEN (* ; "x200000") (\BOUT STRM (LOGOR (LLSH 15 4) (LRSH CHARCODE 18))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 12 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE]) (UTF8.READCCODE [LAMBDA (FILE) (* ; "Edited 3-Feb-2020 10:08 by rmk:") (* ; "Edited 30-Jan-2020 23:08 by rmk:") (LET ((STRM (\GETSTREAM FILE 'INPUT)) BYTE1 BYTE2 BYTE3 BYTE4) (SETQ BYTE1 (\BIN STRM)) (* ;; "Distinguish on header byte, extract number of bytes so we don't read too far") (IF (ILESSP BYTE1 128) THEN (* ;; "Test first: Ascii is the common case") BYTE1 ELSEIF (IGEQ BYTE1 (LLSH 15 4)) THEN (* ; "4 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STRM)) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (SETQ BYTE4 (\BIN STRM)) (CL:WHEN (ILESSP BYTE4 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4))) (LOGOR (LLSH (LOADBYTE BYTE1 0 3) 18) (LLSH (LOADBYTE BYTE2 0 6) 12) (LLSH (LOADBYTE BYTE3 0 6) 6) (LOADBYTE BYTE4 0 6)) ELSEIF (IGEQ BYTE1 (LLSH 7 5)) THEN (* ; "3 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STRM)) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (LOGOR (LLSH (LOADBYTE BYTE1 0 4) 12) (LLSH (LOADBYTE BYTE2 0 6) 6) (LOADBYTE BYTE3 0 6)) ELSE (* ; "Must be 2 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (LOGOR (LLSH (LOADBYTE BYTE1 0 5) 6) (LOADBYTE BYTE2 0 6]) ) (DEFINEQ (TEDIT.COPYTOCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM]) (TEDIT.EXTRACTTOCLIPBOARD [LAMBDA NIL (* ; "Edited 19-Apr-2020 12:17 by rmk:") (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM)) (TEDIT.DELETE TEXTSTREAM (TEDIT.GETSEL TEXTSTREAM]) (TEDIT.SELECTALL [LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 3-May-2020 17:29 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (CL:WHEN TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch TEXTLEN of (TEXTOBJ TEXTSTREAM))) 'LEFT))]) ) (DEFINEQ (SEDIT.COPYTOCLIPBOARD [LAMBDA (CONTEXT) (* ; "Edited 5-May-2018 09:43 by rmk:") (* ; "Edited 24-Apr-2018 20:39 by rmk:") (* ; "Edited 24-Apr-2018 20:33 by rmk:") (* ; "Edited 23-Apr-2018 18:19 by rmk:") (LET (SEL SELTYPE STRING) (* ;; "SEL could be a list of several elements, or a structure, depending on SELTYPE. ") (CL:MULTIPLE-VALUE-SETQ (SEL SELTYPE) (SEDIT:GET-SELECTION CONTEXT)) (* ;; "SELTYPE=NIL means not a valid selection, and SEL is NIL. Non-NIL values are :SUB-LIST, :CHARACTERS, and T") (IF SELTYPE THEN (SETQ STRING (MKSTRING SEL T)) (* ; " Readtable of caller?") (CL:WHEN (OR (EQ SELTYPE :CHARACTERS) (AND (EQ SELTYPE :SUB-LIST) (LISTP SEL))) (GNC STRING) (* ;  "Peel off outer parens for structures or quotes for atom/string characters") (GLC STRING)) (PUTCLIPBOARD STRING))) T]) ) (* ;; "To read/access code translation tables") (DEFINEQ (FILETOCODETABLE [LAMBDA (FILE) (* ; "Edited 28-Apr-2018 16:07 by rmk:") (* rmk%: "20-Dec-87 10:08") (* ;; "Returns a (system-internal) arrayblock holding the contents of FILE.") (RESETLST (LET (LENGTH BLOCK STREAM) (CL:UNLESS (AND (STREAMP FILE) (SETQ STREAM (GETSTREAM FILE 'INPUT T))) [RESETSAVE [SETQ STREAM (OPENSTREAM FILE 'INPUT 'OLD '((SEQUENTIAL T) (TYPE BINARY] '(PROGN (CLOSEF? OLDVALUE]) (* ;; "Blocks are allocated in 4-byte units") (SETQ BLOCK (\ALLOCBLOCK (LRSH LENGTH 2))) (\BINS STREAM BLOCK 0 LENGTH) BLOCK))]) (CODECONVERT [LAMBDA (TABLE CODE) (* ; "Edited 28-Apr-2018 16:01 by rmk:") (* ;;  "Get the CODEth value from the arrayblock TABLE. CODE is a 16-bit index, 16 bits are returned.") (\GETBASE TABLE CODE]) ) (DEFINEQ (MAKECHARCODEMAPS [LAMBDA NIL (* ; "Edited 19-Apr-2020 11:43 by rmk:") (* ; "Edited 3-Feb-2020 10:03 by rmk:") (* ; "Edited 1-Feb-2020 17:45 by rmk:") (* ; "Edited 30-Jan-2020 23:03 by rmk:") (* ;; "Clipboard is UNICODE. Uses an array for character set 0 and for any other highly populated segment, ALIST for relatively unpopulated ones.") (* ;; "Charset 0 is special also because it contains most input characters in both directions.") (* ;; "It sets TOCLIPBOARDMAP and FROMCLIPBOARDMAP each to a pair (array . list)") (LET ((TOCLIPBOARDARRAY (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FROMCLIPBOARDARRAY (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (TOCLIPBOARDLIST NIL) (FROMCLIPBOARDLIST NIL)) [FOR C XC CSETLIST IN CBUNICODETOXEROXRENDERING DO (SETQ XC (CADR C)) (CL:UNLESS (FIXP XC) (SETQ XC (CHARCODE.DECODE XC))) (IF (ILESSP XC 256) THEN (CL:SETF (CL:SVREF TOCLIPBOARDARRAY XC) (CAR C)) ELSE (PUSH [CDR (OR (ASSOC (LRSH XC 8) CSETLIST) (CAR (PUSH CSETLIST (CONS (LRSH XC 8] C)) FINALLY (SETQ TOCLIPBOARDLIST (FOR CS CSA IN CSETLIST COLLECT (CONS (CAR CS) (IF (IGREATERP (LENGTH (CDR CS)) 20) THEN (SETQ CSA (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FOR PAIR IN (CDR CS) DO (CL:SETF (CL:SVREF CSA (LOGAND (CADR PAIR) 255)) (CAR PAIR))) CSA ELSE (FOR PAIR IN (CDR CS) COLLECT (CONS (CADR PAIR) (CAR PAIR] [FOR C CSETLIST IN CBUNICODETOXEROXRENDERING DO (CL:UNLESS (FIXP (CADR C)) [SETQ C (LIST (CAR C) (CHARCODE.DECODE (CADR C]) (IF (ILESSP (CAR C) 256) THEN (CL:SETF (CL:SVREF FROMCLIPBOARDARRAY (CAR C)) (CADR C)) ELSE (PUSH [CDR (OR (ASSOC (LRSH (CAR C) 8) CSETLIST) (CAR (PUSH CSETLIST (CONS (LRSH (CAR C) 8] C)) FINALLY (SETQ FROMCLIPBOARDLIST (FOR CS CSA IN CSETLIST COLLECT (CONS (CAR CS) (IF (IGREATERP (LENGTH (CDR CS)) 20) THEN (SETQ CSA (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FOR PAIR IN (CDR CS) DO (CL:SETF (CL:SVREF CSA (LOGAND (CAR PAIR) 255)) (CADR PAIR))) CSA ELSE (FOR PAIR IN (CDR CS) COLLECT (CONS (CAR PAIR) (CADR PAIR] (SETQ XEROXRENDERING2UNICODEMAP (CONS TOCLIPBOARDARRAY TOCLIPBOARDLIST)) (SETQ UNICODE2XEROXRENDERINGMAP (CONS FROMCLIPBOARDARRAY FROMCLIPBOARDLIST]) (CBMAPCCODE [LAMBDA (CHARMAP CODE) (* ; "Edited 1-Feb-2020 17:49 by rmk:") (* ; "Edited 30-Jan-2020 22:47 by rmk:") (OR [IF (ILESSP CODE 256) THEN (CL:SVREF (CAR CHARMAP) CODE) ELSE (LET [(CS (CDR (ASSOC (LRSH CODE 8) (CDR CHARMAP] (CL:WHEN CS (IF (LISTP CS) THEN (CDR (ASSOC CODE CS)) ELSE (CL:SVREF CS (LOGAND CODE 255))))] CODE]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS XEROXRENDERING2UNICODEMAP UNICODE2XEROXRENDERINGMAP) ) (RPAQQ CBUNICODETOXEROXRENDERING ((8217 RSQ) (8216 LSQ) (8221 RDQ) (8220 LDQ) (8800 NEQ) (146 39) (160 61217) (166 61291) (168 8994) (169 211) (170 227) (172 61290) (173 61219) (174 210) (175 9086) (180 39) (184 203) (185 209) (186 235) (192 61729) (193 61730) (194 61731) (195 61732) (196 61735) (197 61736) (198 225) (199 61741) (200 61744) (201 61745) (202 61746) (203 61749) (204 61758) (205 61759) (206 61760) (207 61764) (208 226) (209 61772) (210 61775) (211 61776) (212 61777) (213 61778) (214 61780) (215 180) (216 233) (217 61791) (218 61792) (219 61793) (220 61797) (221 61803) (222 236) (223 251) (224 61857) (225 61858) (226 61859) (227 61860) (228 61863) (229 61864) (230 241) (231 61869) (232 61872) (233 61873) (234 61874) (235 61877) (236 61886) (237 61887) (238 61888) (239 61892) (240 243) (241 61900) (242 61903) (243 61904) (244 61905) (245 61906) (246 61908) (247 184) (248 249) (249 61919) (250 61920) (251 61921) (252 61925) (253 61931) (254 252) (255 61933) (376 61805) (8594 174) (8592 172) (8593 173) (8595 175) (8712 61258) (8713 61259) (10 13))) (ADDTOVAR CHARACTERNAMES (RSQ "0,271") (LSQ "0,251") (LDQ "0,252") (RDQ "0,272") (NEQ "041,142")) (MAKECHARCODEMAPS) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILESLOAD (SYSLOAD) UNIXCOMM) (INSTALL-CLIPBOARD) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS CLIPBOARD COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1600 6330 (INSTALL-CLIPBOARD 1610 . 4003) (GETCLIPBOARD 4005 . 4667) (PUTCLIPBOARD 4669 . 5286) (PASTEFROMCLIPBOARD 5288 . 5905) (LISPINTERRUPTS.PASTE 5907 . 6328)) (6331 10883 ( UTF8.PRINTCCODE 6341 . 8251) (UTF8.READCCODE 8253 . 10881)) (10884 11972 (TEDIT.COPYTOCLIPBOARD 10894 . 11175) (TEDIT.EXTRACTTOCLIPBOARD 11177 . 11641) (TEDIT.SELECTALL 11643 . 11970)) (11973 13359 ( SEDIT.COPYTOCLIPBOARD 11983 . 13357)) (13416 14584 (FILETOCODETABLE 13426 . 14311) (CODECONVERT 14313 . 14582)) (14585 19744 (MAKECHARCODEMAPS 14595 . 19053) (CBMAPCCODE 19055 . 19742))))) STOP \ No newline at end of file diff --git a/library/CLIPBOARD.~44~ b/library/CLIPBOARD.~44~ deleted file mode 100644 index a9f7e62d..00000000 --- a/library/CLIPBOARD.~44~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "30-Jul-2020 21:33:30"  {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;44 8581 changes to%: (VARS CLIPBOARDCOMS CBUNICODETOXEROXRENDERING) (FNS GETCLIPBOARD PUTCLIPBOARD) previous date%: "24-Jun-2020 20:17:42" {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;41) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD LISPINTERRUPTS.PASTE) (FNS TEDIT.COPYTOCLIPBOARD TEDIT.EXTRACTTOCLIPBOARD TEDIT.SELECTALL) (FNS SEDIT.COPYTOCLIPBOARD) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILES (SYSLOAD) UNIXCOMM UNICODE) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA PUTCLIPBOARD]) (* ; "Enable copy and paste") (DEFINEQ (INSTALL-CLIPBOARD [LAMBDA NIL (* ; "Edited 24-Jun-2020 20:14 by rmk:") (* ; "Edited 19-Apr-2020 12:15 by rmk:") (* ; "Edited 18-Apr-2018 23:00 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.PASTE) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.ORIG) (MOVD 'LISPINTERRUPTS.PASTE 'LISPINTERRUPTS)) (INTERRUPTCHAR (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (INTERRUPTCHAR (CHARCODE "1,V") '(PASTEFROMCLIPBOARD)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT") (* ;; "Paste") (TEDIT.SETFUNCTION (CHARCODE "1,v") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,V") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (* ;; "Copy") (TEDIT.SETFUNCTION (CHARCODE "1,c") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,C") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (* ;; "Extract") (TEDIT.SETFUNCTION (CHARCODE "1,X") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,x") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE) (* ;; "All") (TEDIT.SETFUNCTION (CHARCODE "1,a") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,A") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (* ;; "Quit") (TEDIT.SETFUNCTION (CHARCODE "1,q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,Q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ;  "SEDIT copy: INTERRUPTCHAR does paste") (SEDIT:ADD-COMMAND "1,c" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:ADD-COMMAND "1,C" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:RESET-COMMANDS))]) (GETCLIPBOARD [LAMBDA NIL (* ; "Edited 30-Jul-2020 21:23 by rmk:") (* ; "Edited 25-Apr-2018 16:56 by rmk:") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbpaste")) (\EXTERNALFORMAT s :UTF8) [SETFILEINFO s 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (RETFROM (FUNCTION READCCODE) NIL] (CONCATCODES (BIND C WHILE (SETQ C (READCCODE s)) COLLECT C]) (PUTCLIPBOARD (CL:LAMBDA (STRING) (* ; "Edited 30-Jul-2020 21:26 by rmk:") (* ; "Edited 25-Apr-2018 16:49 by rmk:") (* ;; "Clipboard is UNICODE and UTF8") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbcopy")) (\EXTERNALFORMAT s :UTF8) (PRIN3 STRING s)))) (PASTEFROMCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 13:56 by rmk:") (* ; "Edited 17-Apr-2018 23:11 by rmk:") (* ;;  "Should be able to just call COPYINSERT, but the default BKSYSBUF puts in string qujotes ") (LET ((STR (GETCLIPBOARD))) (IF (WINDOWPROP (PROCESS.WINDOW (TTY.PROCESS)) 'COPYINSERTFN) THEN (COPYINSERT STR) ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C]) (LISPINTERRUPTS.PASTE [LAMBDA NIL (* ; "Edited 18-Apr-2018 22:59 by rmk:") (* ;; "So paste interrupts will be installed in every process") (APPEND [LIST (LIST (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (LIST (CHARCODE "1,V") '(PASTEFROMCLIPBOARD] (LISPINTERRUPTS.ORIG]) ) (DEFINEQ (TEDIT.COPYTOCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM]) (TEDIT.EXTRACTTOCLIPBOARD [LAMBDA NIL (* ; "Edited 19-Apr-2020 12:17 by rmk:") (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM)) (TEDIT.DELETE TEXTSTREAM (TEDIT.GETSEL TEXTSTREAM]) (TEDIT.SELECTALL [LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 3-May-2020 17:29 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (CL:WHEN TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch TEXTLEN of (TEXTOBJ TEXTSTREAM))) 'LEFT))]) ) (DEFINEQ (SEDIT.COPYTOCLIPBOARD [LAMBDA (CONTEXT) (* ; "Edited 5-May-2018 09:43 by rmk:") (* ; "Edited 24-Apr-2018 20:39 by rmk:") (* ; "Edited 24-Apr-2018 20:33 by rmk:") (* ; "Edited 23-Apr-2018 18:19 by rmk:") (LET (SEL SELTYPE STRING) (* ;; "SEL could be a list of several elements, or a structure, depending on SELTYPE. ") (CL:MULTIPLE-VALUE-SETQ (SEL SELTYPE) (SEDIT:GET-SELECTION CONTEXT)) (* ;; "SELTYPE=NIL means not a valid selection, and SEL is NIL. Non-NIL values are :SUB-LIST, :CHARACTERS, and T") (IF SELTYPE THEN (SETQ STRING (MKSTRING SEL T)) (* ; " Readtable of caller?") (CL:WHEN (OR (EQ SELTYPE :CHARACTERS) (AND (EQ SELTYPE :SUB-LIST) (LISTP SEL))) (GNC STRING) (* ;  "Peel off outer parens for structures or quotes for atom/string characters") (GLC STRING)) (PUTCLIPBOARD STRING))) T]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILESLOAD (SYSLOAD) UNIXCOMM UNICODE) (INSTALL-CLIPBOARD) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA PUTCLIPBOARD) ) (PUTPROPS CLIPBOARD COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1279 5776 (INSTALL-CLIPBOARD 1289 . 3682) (GETCLIPBOARD 3684 . 4300) (PUTCLIPBOARD 4302 . 4732) (PASTEFROMCLIPBOARD 4734 . 5351) (LISPINTERRUPTS.PASTE 5353 . 5774)) (5777 6865 ( TEDIT.COPYTOCLIPBOARD 5787 . 6068) (TEDIT.EXTRACTTOCLIPBOARD 6070 . 6534) (TEDIT.SELECTALL 6536 . 6863 )) (6866 8252 (SEDIT.COPYTOCLIPBOARD 6876 . 8250))))) STOP \ No newline at end of file diff --git a/library/FILEBROWSER b/library/FILEBROWSER index 5cc6690e..75e82857 100644 --- a/library/FILEBROWSER +++ b/library/FILEBROWSER @@ -1,226 +1 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "11-Sep-2001 09:26:14" |{DSK}medley3.5>library>FILEBROWSER.;8| 152759 |changes| |to:| (FNS FB.PROMPTFORINPUT) |previous| |date:| "20-Nov-2000 14:25:02" |{DSK}medley3.5>library>FILEBROWSER.;7|) ; Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1993, 1994, 1999, 2000, 2001 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT FILEBROWSERCOMS) (RPAQQ FILEBROWSERCOMS ((COMS (FILES ATTACHEDWINDOW ICONW TABLEBROWSER) (* |;;| "JDS 11/94 FB.ICONSPEC is now an INITVAR so we can create smaller ones in profiles for, e.g., laptops.") (INITVARS (FB.EXPUNGE?MENU) (FB.BROWSERFONT DEFAULTFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT) (FB.PROMPTFONT LITTLEFONT) (FB.HARDCOPY.FONT) (FB.HARDCOPY.DIRECTORY.FONT) (FB.PROMPTLINES 3) (FB.MENUFONT MENUFONT) (FB.OVERFLOW.MAXABSOLUTE 30) (FB.OVERFLOW.MAXFRAC 0.06) (FB.DEFAULT.EDITOR 'TEDIT) (FB.DEFAULT.INFO '(SIZE CREATIONDATE AUTHOR)) (FB.ICONSPEC '(#*(83 70)OOOOOOOOOOOOOOOOOOOON@@@OOOOOOOOOOOOOOOOOOOON@@@L@@@@@@@@@@@@@@@@@@@F@@@L@@@@@@@@@@@@@@@@@@@F@@@LOOOOOOOOOOOOOOOOOONF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@GOOOOOL@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@DCOOOHD@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@DOOOOND@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@GOOOOOL@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@COOOOOH@@@@@BF@@@LH@@@@@COOOOOH@@@@@BF@@@LH@@@@@B@@@@@H@@@@@BF@@@LH@@@@@A@@@@A@@@@@@BF@@@LH@@@@@@OOOON@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LOOOOOOOOOOOOOOOOOONF@@@L@@@@@@@@@@@@@@@@@@@F@@@L@@@@@@@@@@@@@@@@@@@F@@@OOOOOOOOOOOOOOOOOOOON@@@OOOOOOOOOOOOOOOOOOOON@@@ NIL (5 5 73 40)))) (APPENDVARS (FONTVARS (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT LITTLEFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT))) (P (* |;;| "FONTSET fills in the variables in FONTVARS for us, so do it.") (FONTSET (FONTSET))) (ADDVARS (CACHEDMENUS FB.EXPUNGE?MENU)) (VARS FB.MENU.ITEMS FB.VERSION.MENU.ITEMS FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.INFO.MENU.ITEMS FB.DEFAULT.NAME.WIDTH FB.INFO.FIELDS FB.INFOSHADE FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE)) (COMS (* \; "Entries") (COMMANDS "fb") (FNS FB FB.COPYBINARYCOMMAND FB.COPYTEXTCOMMAND FILEBROWSER FB.TABLEBROWSER FB.SELECTEDFILES FB.FETCHFILENAME FB.PROMPTWPRINT FB.PROMPTW.FORMAT FB.PROMPTFORINPUT FB.YES-OR-NO-P FB.ALLOW.ABORT \\FB.HARDCOPY.TOFILE.EXTENSION) (* \; "Setup") (FNS FB.STARTUP FB.MAKERIGIDWINDOW) (FNS FB.PRINTFN FB.COPYFN)) (COMS (* \;  "commands and major subfunctions") (FNS FB.MENU.WHENSELECTEDFN FB.COMMANDSELECTEDFN FB.SUBITEMP FB.MAKE.BROWSER.BUSY FB.FINISH.COMMAND FB.HANDLE.ABORT.BUTTON) (FNS FB.DELETECOMMAND FB.DELVERCOMMAND FB.IS.NOT.SUBDIRECTORY.ITEM FB.DELVER.FILES FB.DELETE.FILE) (FNS FB.UNDELETECOMMAND FB.UNDELETEALLCOMMAND FB.UNDELETE.FILE) (FNS FB.COPYCOMMAND FB.RENAMECOMMAND FB.COPY/RENAME.COMMAND FB.COPY/RENAME.ONE FB.COPY/RENAME.MANY FB.MERGE.DIRECTORIES FB.GREATEST.PREFIX FB.MAYBE.INSERT.FILE FB.GET.NEW.FILE.SPEC FB.CANONICAL.DIRECTORY) (FNS FB.HARDCOPYCOMMAND FB.HARDCOPY.TOFILE) (FNS FB.EDITCOMMAND FB.EDITLISPFILE FB.BROWSECOMMAND) (FNS FB.FASTSEECOMMAND FB.FASTSEE.ONEFILE FB.SEEFULLFN FB.SEEBUTTONFN) (FNS FB.LOADCOMMAND FB.COMPILECOMMAND FB.OPERATE.ON.FILES) (FNS FB.UPDATECOMMAND FB.MAYBE.EXPUNGE FB.UPDATEBROWSERITEMS FB.DATE FB.ADJUST.DATE.WIDTH FB.SET.BROWSER.TITLE FB.MAYBE.WIDEN.NAMES FB.SET.DEFAULT.NAME.WIDTH FB.CREATE.FILEBUCKET FB.CHECK.NAME.LENGTH FB.ADD.FILEGROUP FB.INSERT.DIRECTORY FB.MAKE.SUBDIRECTORY.ITEM FB.ADD.FILE FB.INSERT.FILE FB.ANALYZE.PATTERN FB.CANONICALIZE.PATTERN FB.GETALLFILEINFO) (FNS FB.SORT.VERSIONS FB.DECREASING.VERSION FB.INCREASING.VERSION FB.NAMES.DECREASING.VERSION FB.NAMES.INCREASING.VERSION FB.DECREASING.NUMERIC.ATTR FB.INCREASING.NUMERIC.ATTR FB.ALPHABETIC.ATTR) (FNS FB.SORTCOMMAND FB.INSERT.SUBDIRECTORIES FB.GET.SORT.MENU) (FNS FB.EXPUNGECOMMAND FB.NEWPATTERNCOMMAND FB.NEWINFOCOMMAND FB.DEPTHCOMMAND FB.SHAPECOMMAND FB.REMOVE.FILE FB.COUNT.FILE.CHANGE FB.SETNEWPATTERN FB.GET.NEWPATTERN FB.OPTIONSCOMMAND)) (COMS (* \; "window functions") (FNS FB.INFOMENU.SHADEINITIALSELECTIONS FB.INFO.ITEM.NAMED) (FNS FB.MAKECOUNTERWINDOW FB.COUNTERW.REDISPLAYFN FB.UPDATE.COUNTERS FB.DISPLAY.COUNTERS FB.COUNTER.STRING) (FNS FB.MAKEHEADINGWINDOW FB.HEADINGW.REDISPLAYFN FB.HEADINGW.RESHAPEFN FB.HEADINGW.DISPLAY) (FNS FB.ICONFN FB.INFOMENU.WHENSELECTEDFN FB.CLOSEFN FB.EXPUNGE?.MENU FB.AFTERCLOSEFN FB.CLOSE&EXPUNGE) (FNS FB.HARDCOPY.DIRECTORY FB.HARDCOPY.PRINT.TITLE FB.HARDCOPY.MAXWIDTH)) (DECLARE\: EVAL@COMPILE DONTCOPY (FILES (SOURCE) TABLEBROWSERDECLS) (RECORDS INFOFIELD FBFILEDATA FILEBROWSER) (CONSTANTS FB.MORE.BORDER FB.NULL.VERSION) (MACROS NULL.VERSIONP NULL.DIRECTORYP EQ.DIRECTORYP NULL.FIELDP) (GLOBALVARS FB.ICONFONT FB.BROWSERFONT FB.PROMPTFONT FB.MENUFONT FB.HARDCOPY.FONT FB.HARDCOPY.DIRECTORY.FONT FB.EXPUNGE?MENU FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.MENU.ITEMS FB.DEFAULT.INFO FB.INFOSHADE FB.INFO.MENU.ITEMS FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE DIRCOMMANDS FB.PROMPTLINES FB.INFO.FIELDS |WindowTitleDisplayStream| FB.ICONSPEC FB.DEFAULT.NAME.WIDTH FB.OVERFLOW.MAXABSOLUTE FB.OVERFLOW.MAXFRAC FB.DEFAULT.EDITOR FB.BROWSER.DIRECTORY.FONT ITALICFONT PRINTFILETYPES) (LOCALVARS . T)) (INITRECORDS FILEBROWSER FBFILEDATA) (SYSRECORDS FILEBROWSER FBFILEDATA) (DECLARE\: DONTEVAL@LOAD DOCOPY (P (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T)) (ADDVARS (*ATTACHED-WINDOW-COMMAND-SYNONYMS* (HARDCOPYIMAGEW.TOFILE . HARDCOPYIMAGEW) (HARDCOPYIMAGEW.TOPRINTER . HARDCOPYIMAGEW)) (|BackgroundMenuCommands| ("FileBrowser" '(FILEBROWSER) "Opens a filebrowser window; prompts for pattern" ))) (VARS (|BackgroundMenu|))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA FB) (NLAML) (LAMA FB.PROMPTW.FORMAT FB.PROMPTWPRINT))) )) (FILESLOAD ATTACHEDWINDOW ICONW TABLEBROWSER) (* |;;| "JDS 11/94 FB.ICONSPEC is now an INITVAR so we can create smaller ones in profiles for, e.g., laptops." ) (RPAQ? FB.EXPUNGE?MENU ) (RPAQ? FB.BROWSERFONT DEFAULTFONT) (RPAQ? FB.BROWSER.DIRECTORY.FONT BOLDFONT) (RPAQ? FB.PROMPTFONT LITTLEFONT) (RPAQ? FB.HARDCOPY.FONT ) (RPAQ? FB.HARDCOPY.DIRECTORY.FONT ) (RPAQ? FB.PROMPTLINES 3) (RPAQ? FB.MENUFONT MENUFONT) (RPAQ? FB.OVERFLOW.MAXABSOLUTE 30) (RPAQ? FB.OVERFLOW.MAXFRAC 0.06) (RPAQ? FB.DEFAULT.EDITOR 'TEDIT) (RPAQ? FB.DEFAULT.INFO '(SIZE CREATIONDATE AUTHOR)) (RPAQ? FB.ICONSPEC '(#*(83 70)OOOOOOOOOOOOOOOOOOOON@@@OOOOOOOOOOOOOOOOOOOON@@@L@@@@@@@@@@@@@@@@@@@F@@@L@@@@@@@@@@@@@@@@@@@F@@@LOOOOOOOOOOOOOOOOOONF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@GOOOOOL@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@DCOOOHD@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@DOOOOND@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@GOOOOOL@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@COOOOOH@@@@@BF@@@LH@@@@@COOOOOH@@@@@BF@@@LH@@@@@B@@@@@H@@@@@BF@@@LH@@@@@A@@@@A@@@@@@BF@@@LH@@@@@@OOOON@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LOOOOOOOOOOOOOOOOOONF@@@L@@@@@@@@@@@@@@@@@@@F@@@L@@@@@@@@@@@@@@@@@@@F@@@OOOOOOOOOOOOOOOOOOOON@@@OOOOOOOOOOOOOOOOOOOON@@@ NIL (5 5 73 40))) (APPENDTOVAR FONTVARS (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT LITTLEFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT)) (* |;;| "FONTSET fills in the variables in FONTVARS for us, so do it.") (FONTSET (FONTSET)) (ADDTOVAR CACHEDMENUS FB.EXPUNGE?MENU) (RPAQQ FB.MENU.ITEMS ((|Delete| FB.DELETECOMMAND "Marks selected files for deletion. \ - (Use EXPUNGE to remove files from system)" (SUBITEMS ("Delete Selected Files" FB.DELETECOMMAND "Marks the selected files for deletion.") ("Delete Old Versions" FB.DELVERCOMMAND "Marks for deletion old versions of all files in the browser.\ -You specify how many versions to keep." ))) (|Undelete| FB.UNDELETECOMMAND "Removes deletion mark for selected files" (SUBITEMS ("Undelete ALL Files" FB.UNDELETEALLCOMMAND "Removes deletion mark from all files in the browser"))) (|Copy| FB.COPYCOMMAND "Copies selected files (prompts for new file name/directory)" (SUBITEMS ("Copy using TEXT FileType" FB.COPYTEXTCOMMAND "Forces the copying of selected files to be done as TEXT-files") ("Copy using BINARY FileType" FB.COPYBINARYCOMMAND "Forces the copying of selected files to be done as BINARY-files"))) (|Rename| FB.RENAMECOMMAND "Renames (moves) selected files (prompts for new name/directory)") (|Hardcopy| FB.HARDCOPYCOMMAND "Produces hardcopy of selected files on your default printer" (SUBITEMS ("To a file" (FB.HARDCOPYCOMMAND FILE) "Generates a hardcopy master of selected file; prompts for filename and format" ) ("To a printer" (FB.HARDCOPYCOMMAND PRINTER) "Sends hardcopy of selected files to a printer of your choosing"))) (|See| FB.FASTSEECOMMAND "Displays selected files one at a time in a separate window" (SUBITEMS ("Fast SEE Pretty" FB.FASTSEECOMMAND "Views file quickly, uses font information, no scrolling backwards") ("Fast SEE Unformatted" (FB.FASTSEECOMMAND T) "Views file quickly, shows raw characters, no scrolling backwards") ("Scrollable & Pretty" (FB.EDITCOMMAND READONLY) "Views file with font information in a fully scrollable window") ("FileBrowse" FB.BROWSECOMMAND "Recursively call FileBrowser on the selected subdirectory"))) (|Edit| FB.EDITCOMMAND "Calls an editor on the selected files (use submenu to specify editor)" (SUBITEMS ("TEdit" (FB.EDITCOMMAND TEDIT) "Calls TEdit (text editor) on selected files") ("Lisp Edit" (FB.EDITCOMMAND LISP) "Calls Lisp editor on selected files"))) (|Load| FB.LOADCOMMAND "LOADs selected files" (SUBITEMS ("IL:LOAD" FB.LOADCOMMAND "LOADs selected files") ("CL:LOAD" (FB.LOADCOMMAND CL:LOAD) "Performs CL:LOAD on selected files" ) ("Load PROP" (FB.LOADCOMMAND PROP) "Loads the selected files with LDFLG = PROP" ) ("Load SYSLOAD" (FB.LOADCOMMAND SYSLOAD) "System-loads the files (fast but not undoable)" ) (LOADFROM (FB.LOADCOMMAND LOADFROM) "Performs LOADFROM on selected files" ) (LOADCOMP (FB.LOADCOMMAND LOADCOMP) "Performs LOADCOMP on selected files" ))) (|Compile| FB.COMPILECOMMAND "Compiles selected LISP source files using default compiler" (SUBITEMS (TCOMPL (FB.COMPILECOMMAND TCOMPL) "Calls TCOMPL on selected files") (BCOMPL (FB.COMPILECOMMAND BCOMPL) "Calls BCOMPL on selected files") (COMPILE-FILE (FB.COMPILECOMMAND CL:COMPILE-FILE) "COMPILE-FILE's selected files"))) (|Expunge| FB.EXPUNGECOMMAND "Permanently removes from the file system all files marked for deletion") (|Recompute| FB.UPDATECOMMAND "Recomputes set of files satisfying selection pattern" (SUBITEMS ("Same Pattern" FB.UPDATECOMMAND "Recomputes set of files satisfying current pattern") ("New Pattern" FB.NEWPATTERNCOMMAND "Prompts for a new selection pattern and updates browser") ("New Info" FB.NEWINFOCOMMAND "Change the set of file attributes that are displayed") ("Set Depth" FB.DEPTHCOMMAND "Change the depth to which future Recomputes will enumerate the directory (NS servers only)" ) ("Shape to Fit" FB.SHAPECOMMAND "Widen or narrow the browser so that all information is visible"))) (|Sort| FB.SORTCOMMAND "Sorts all the files in the browser by the attribute of your choice"))) (RPAQQ FB.VERSION.MENU.ITEMS (("1" 1 "Keep only one version of the files") ("2" 2 "Keep two versions of the files") ("3" 3 "Keep three versions of the files") ("4" 4 "Keep four versions of the files") ("Other" :NUMBER "Select number of versions to keep"))) (RPAQQ FB.CLOSE.MENU.ITEMS (("Expunge deleted files" 'EXPUNGE "Erases all files still marked 'deleted'") ("Don't expunge" 'NOEXPUNGE "Proceeds (closes or updates browser) without expunging deleted files.\ -Your deletions are thus ignored." ))) (RPAQQ FB.DEPTH.MENU.ITEMS (("Global default" :GLOBAL "Set depth using the global default (FILING.ENUMERATION.DEPTH)" ) ("Infinite" T "Set depth to infinity, i.e., enumerate all levels of directory" ) ("1" 1 "Set depth to 1, i.e., enumerate just the top level of the directory" ) ("2" 2 "Set depth to 2") ("Other" :NUMBER "Set depth to some other finite depth"))) (RPAQQ FB.INFO.MENU.ITEMS ((|Length| LENGTH "Toggles Length display") (|ByteSize| BYTESIZE "Toggles ByteSize display") (|Pages| SIZE "Toggles Pages display") (|Type| TYPE "Toggles Type display") (|Created| CREATIONDATE "Toggles Created display") (|Written| WRITEDATE "Toggles Written display") (|Read| READDATE "Toggles Read display") (|Author| AUTHOR "Toggles Author display"))) (RPAQQ FB.DEFAULT.NAME.WIDTH 140) (RPAQQ FB.INFO.FIELDS ((LENGTH " Length" 70 (FIX 56) "99999999") (SIZE "Pages" 50 (FIX 35) "99999") (BYTESIZE "Byt" 28 (FIX 14) "99") (TYPE "Type" 55 NIL "INTERPRESS") (CREATIONDATE "Created" 170 DATE) (READDATE "Read" 170 DATE) (WRITEDATE "Written" 170 DATE) (AUTHOR "Author" 120))) (RPAQQ FB.INFOSHADE 32800) (RPAQQ FB.ITEMUNSELECTEDSHADE 0) (RPAQQ FB.ITEMSELECTEDSHADE 4672) (* \; "Entries") (DEFCOMMAND "fb" (&REST PAT&PROPS) (APPLY 'FB PAT&PROPS)) (DEFINEQ (FB -(NLAMBDA PATTERN (* \; "Edited 26-Feb-88 13:50 by bvm") (* |;;;| "FILEBROWSER entry from top-level exec: FB PATTERN ... PROPS ...") (DESTRUCTURING-BIND (PAT . PROPS) (NLAMBDA.ARGS PATTERN) (LET (OPTIONS) (|for| TAIL |on| PROPS |when| (AND (CL:KEYWORDP (CAR TAIL)) (CDR TAIL)) |do| (* \; "Interpret keyword tail of attributes as OPTIONS.") (RETURN (SETQ PROPS (LDIFF PROPS (SETQ OPTIONS TAIL))))) (ADD.PROCESS (BQUOTE ((\\\, (FUNCTION FILEBROWSER)) (QUOTE (\\\, PAT)) (QUOTE (\\\, PROPS)) (QUOTE (\\\, OPTIONS)))) (QUOTE NAME) (QUOTE FB)))) NIL) -) (FB.COPYBINARYCOMMAND -(LAMBDA (BROWSER) (* \; "Edited 19-Oct-90 18:18 by gadener") (FB.COPY/RENAME.COMMAND BROWSER (QUOTE |Copy|) (CONS (FUNCTION COPYFILE) (QUOTE ((TYPE BINARY)))))) -) (FB.COPYTEXTCOMMAND -(LAMBDA (BROWSER) (* \; "Edited 19-Oct-90 18:55 by gadener") (FB.COPY/RENAME.COMMAND BROWSER (QUOTE |Copy|) (CONS (FUNCTION COPYFILE) (QUOTE ((TYPE TEXT)))))) -) (FILEBROWSER -(LAMBDA (FILESPEC ATTRIBUTES OPTIONS) (* \; "Edited 30-Aug-94 19:45 by jds") (PROG ((TITLEFONT (DSPFONT NIL |WindowTitleDisplayStream|)) (BROWSERFONTHEIGHT (FONTPROP FB.BROWSERFONT (QUOTE HEIGHT))) (MENU-ITEMS FB.MENU.ITEMS) (MENU-TITLE "FB Commands") BROWSER PROMPTWHEIGHT COUNTERHEIGHT BROWSERWINDOW BROWSERWIDTH COMMANDMENU COMMANDMENUWIDTH COMMANDMENUWINDOW HEADINGWINDOW REGION TITLE DEPTH) (COND ((AND (LISTP OPTIONS) (SMALLP (CAR OPTIONS)) (AND (EQLENGTH OPTIONS 4) (EVERY OPTIONS (FUNCTION NUMBERP)))) (* \; "Old style") (SETQ REGION OPTIONS) (SETQ OPTIONS)) (T (|for| TAIL |on| OPTIONS |by| (CDDR TAIL) |do| (PROG ((KEY (CAR TAIL)) (VALUE (CADR TAIL))) RETRY (SELECTQ KEY (:REGION (SETQ REGION VALUE)) (:TITLE (SETQ TITLE VALUE)) ((:MENU-TITLE MENU.TITLE) (SETQ MENU-TITLE VALUE)) ((:MENU-ITEMS MENU.ITEMS) (SETQ MENU-ITEMS VALUE)) (:DEPTH (SETQ DEPTH VALUE)) (|if| (AND (NOT (CL:KEYWORDP KEY)) (SETQ KEY (CL:FIND-SYMBOL (STRING KEY) *KEYWORD-PACKAGE*))) |then| (* \; "for backward compatibility, coerce other symbols to keywords") (GO RETRY))))))) (SETQ ATTRIBUTES (COND (ATTRIBUTES (* \; "Caller specifies which attributes to use") (|for| X |in| ATTRIBUTES |collect| (OR (CADR (FB.INFO.ITEM.NAMED X FB.INFO.MENU.ITEMS)) (AND (LISTP DIRCOMMANDS) (OR (|for| PAIR |in| DIRCOMMANDS |when| (AND (LISTP PAIR) (STRING-EQUAL X (CAR PAIR))) |do| (* \; "Found synonym in dircommands. This also takes care of attribute being in different packages") (RETURN (CDR PAIR))) (PROGN (* \; "Try spelling correction. Wanted to get synonyms this way, but MISSPELLED? seems to be package-sensitive.") (MISSPELLED? X 90 DIRCOMMANDS)))) (\\ILLEGAL.ARG X)))) (T FB.DEFAULT.INFO))) (PROGN (* \; "Figure out the size of the fixed pieces before prompting for a region") (SETQ COMMANDMENU (|create| MENU MENUFONT _ FB.MENUFONT ITEMS _ MENU-ITEMS CENTERFLG _ T MENUCOLUMNS _ 1 WHENSELECTEDFN _ (FUNCTION FB.MENU.WHENSELECTEDFN) TITLE _ MENU-TITLE)) (SETQ COMMANDMENUWIDTH (|fetch| (MENU IMAGEWIDTH) |of| COMMANDMENU)) (SETQ PROMPTWHEIGHT (HEIGHTIFWINDOW (TIMES FB.PROMPTLINES (FONTPROP FB.PROMPTFONT (QUOTE HEIGHT))))) (SETQ COUNTERHEIGHT (HEIGHTIFWINDOW (FONTPROP TITLEFONT (QUOTE HEIGHT)) T))) (PROGN (* |;;| "First make the main window, carved out of the space in REGION leftover after the fixed parts are accounted for") (COND ((NOT REGION) (PROMPTPRINT (CL:FORMAT NIL "Specify region for FileBrowser~@[ on ~A~]" FILESPEC)) (SETQ REGION (GETREGION (PROGN (* \; "Min width is menu plus enough space to print a name") (+ COMMANDMENUWIDTH FB.DEFAULT.NAME.WIDTH TB.LEFT.MARGIN)) (PROGN (* \; "Min height is prompt window plus counter window plus heading plus 5 lines of files") (+ PROMPTWHEIGHT COUNTERHEIGHT (TIMES 6 BROWSERFONTHEIGHT))))) (CLRPROMPT))) (|if| (AND (NULL FILESPEC) (NOT (TTY.PROCESSP))) |then| (* \; "Grab the tty now, so that user can start typing ahead") (TTY.PROCESS (THIS.PROCESS)) (ALLOW.BUTTON.EVENTS)) (SETQ BROWSERWINDOW (CREATEW (|create| REGION |using| REGION WIDTH _ (SETQ BROWSERWIDTH (- (|fetch| (REGION WIDTH) |of| REGION) COMMANDMENUWIDTH)) HEIGHT _ (- (|fetch| (REGION HEIGHT) |of| REGION) (+ COUNTERHEIGHT PROMPTWHEIGHT BROWSERFONTHEIGHT))))) (DSPFONT FB.BROWSERFONT BROWSERWINDOW) (WINDOWPROP BROWSERWINDOW (QUOTE FILEBROWSER) (SETQ BROWSER (|create| FILEBROWSER BROWSERWINDOW _ BROWSERWINDOW BROWSERFONT _ FB.BROWSERFONT OVERFLOWSPACING _ (TIMES 3 (CHARWIDTH (CHARCODE \a) FB.BROWSERFONT)) SORTBY _ (FUNCTION FB.NAMES.DECREASING.VERSION) FIXEDTITLE _ TITLE INFOMENUCHOICES _ ATTRIBUTES FBLOCK _ (CREATE.MONITORLOCK) FBDEPTH _ DEPTH)))) (PROGN (* \; "Atop this sits the black heading window, with labels for each column in browser") (|replace| (FILEBROWSER HEADINGWINDOW) |of| BROWSER |with| (SETQ HEADINGWINDOW (FB.MAKEHEADINGWINDOW BROWSERWINDOW BROWSERWIDTH BROWSERFONTHEIGHT FB.BROWSERFONT)))) (PROGN (* \; "Atop that is the counter window, whose title contains the file pattern") (FB.MAKECOUNTERWINDOW BROWSERWINDOW TITLEFONT BROWSERWIDTH COUNTERHEIGHT TITLE)) (PROGN (* \; "Main command menu sits on the right side") (SETQ COMMANDMENUWINDOW (MENUWINDOW COMMANDMENU)) (ATTACHWINDOW COMMANDMENUWINDOW BROWSERWINDOW (QUOTE RIGHT) (QUOTE TOP))) (PROGN (* \; "Finally the prompt window atop it all") (|replace| (FILEBROWSER PROMPTWINDOW) |of| BROWSER |with| (FB.MAKERIGIDWINDOW (GETPROMPTWINDOW BROWSERWINDOW FB.PROMPTLINES FB.PROMPTFONT)))) (PROGN (* \; "Now make them all open. For some reason, attaching the menu didn't open it") (TOTOPW BROWSERWINDOW)) (|replace| (FILEBROWSER ABORTWINDOW) |of| BROWSER |with| (CONS (MENUWINDOW (|create| MENU ITEMS _ (QUOTE (("--Abort--" NIL "Abort the current FileBrowser operation"))) CENTERFLG _ T MENUOUTLINESIZE _ 2 MENUFONT _ (FONTCOPY FB.MENUFONT (QUOTE WEIGHT) (QUOTE BOLD)) WHENSELECTEDFN _ (FUNCTION FB.HANDLE.ABORT.BUTTON))) COMMANDMENUWINDOW)) (|for| W |in| (LIST COMMANDMENUWINDOW (CAR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER)) (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER) (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER)) |bind| OLDCOMS |when| (LISTP (SETQ OLDCOMS (WINDOWPROP W (QUOTE PASSTOMAINCOMS)))) |do| (* \; "Make all these subwindows pass hardcopy on to the main window") (WINDOWPROP W (QUOTE PASSTOMAINCOMS) (UNION (QUOTE (HARDCOPYIMAGEW)) OLDCOMS))) (|replace| (FILEBROWSER TABLEBROWSER) |of| BROWSER |with| (TB.MAKE.BROWSER NIL BROWSERWINDOW (LIST (QUOTE PRINTFN) (FUNCTION FB.PRINTFN) (QUOTE COPYFN) (FUNCTION FB.COPYFN) (QUOTE USERDATA) BROWSER (QUOTE CLOSEFN) (FUNCTION FB.CLOSEFN) (QUOTE AFTERCLOSEFN) (FUNCTION FB.AFTERCLOSEFN) (QUOTE HEADINGWINDOW) HEADINGWINDOW))) (WINDOWPROP BROWSERWINDOW (QUOTE HARDCOPYFN) (FUNCTION FB.HARDCOPY.DIRECTORY)) (WINDOWPROP BROWSERWINDOW (QUOTE ICONFN) (FUNCTION FB.ICONFN)) (|if| (SETQ FILESPEC (|if| FILESPEC |then| (DIRECTORY.FILL.PATTERN FILESPEC) |else| (FB.STARTUP BROWSER COMMANDMENU (FUNCTION FB.GET.NEWPATTERN)))) |then| (* \; "Have a pattern to work with. Now enumerate it in a new process.") (FB.SETNEWPATTERN BROWSER FILESPEC) (ADD.PROCESS (BQUOTE ((\\\, (FUNCTION FB.STARTUP)) (QUOTE (\\\, BROWSER)) (QUOTE (\\\, COMMANDMENU)) (QUOTE (\\\, (FUNCTION FB.UPDATEBROWSERITEMS))))) (QUOTE NAME) (QUOTE |FB-Update|) (QUOTE BEFOREEXIT) (QUOTE DON\'T))) (RETURN BROWSERWINDOW))) -) (FB.TABLEBROWSER -(LAMBDA (BROWSER) (* \; "Edited 4-Feb-88 23:13 by bvm:") (|ffetch| (FILEBROWSER TABLEBROWSER) |of| (\\DTEST BROWSER (QUOTE FILEBROWSER)))) -) (FB.SELECTEDFILES -(LAMBDA (BROWSER NOERRORFLG) (* \; "Edited 29-Jan-88 12:38 by bvm") (* |;;| "User entry to get the set of selected files, as tableitems, from a filebrowser. If NOERRORFLG is NIL, will print a message if no files are selected.") (COND ((TB.COLLECT.ITEMS (|ffetch| (FILEBROWSER TABLEBROWSER) |of| (\\DTEST BROWSER (QUOTE FILEBROWSER))) (QUOTE SELECTED))) ((NOT NOERRORFLG) (FB.PROMPTWPRINT BROWSER T "No files are selected") NIL))) -) (FB.FETCHFILENAME -(LAMBDA (ITEM) (* \; "Edited 29-Jan-88 12:37 by bvm") (* |;;| "User entry to get filename from a browser tableitem.") (|fetch| (FBFILEDATA FILENAME) |of| (|ffetch| TIDATA |of| (\\DTEST ITEM (QUOTE TABLEITEM))))) -) (FB.PROMPTWPRINT -(LAMBDA U (* \; "Edited 4-Feb-88 23:08 by bvm:") (COND ((< U 2) (ERROR "not enough args to PROMPTWPRINT")) (T (LET ((WINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST (ARG U 1) (QUOTE FILEBROWSER)))) THING) (* \; "CAR is window, CDR is height in lines") (|for| ITEM |from| 2 |to| U |do| (SELECTQ (SETQ THING (ARG U ITEM)) (T (TERPRI WINDOW)) (CLEAR (CLEARW WINDOW)) (FRESH (FRESHLINE WINDOW)) (PRIN1 THING WINDOW))))))) -) (FB.PROMPTW.FORMAT -(CL:LAMBDA (BROWSER FORMAT-STRING &REST ARGS) (* \; "Edited 4-Feb-88 23:15 by bvm:") (* |;;| "Outputs to FOLDER's prompt window using FORMAT.") (LET ((*PRINT-CASE* :UPCASE) (*PRINT-BASE* 10) (WINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST BROWSER (QUOTE FILEBROWSER))))) (* |;;| "*PRINT-CASE* is bound so symbols get printed in \"expected\" case. *PRINT-BASE* is 10 for benefit of printing numbers in the non-format case.") (CL:APPLY (FUNCTION CL:FORMAT) WINDOW FORMAT-STRING ARGS))) -) (FB.PROMPTFORINPUT (LAMBDA (PROMPT DEFAULT BROWSER ABORTFLG DONTCLEAR) (* \; "Edited 22-Nov-88 15:33 by bvm") (* |;;;| "Prompt for input for browser BROWSER with question PROMPT offering default answer DEFAULT. If ABORTFLG is true and response is NIL, prints '... aborted'") (LET* ((PWINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST BROWSER 'FILEBROWSER))) (PROMPTWIDTH (STRINGWIDTH PROMPT PWINDOW)) (WINDOWWIDTH (WINDOWPROP PWINDOW 'WIDTH)) RESULT) (COND (DONTCLEAR (FRESHLINE PWINDOW)) (T (CLEARW PWINDOW))) (COND ((> (+ PROMPTWIDTH (STRINGWIDTH (OR DEFAULT "XXX") PWINDOW)) WINDOWWIDTH) (* |;;| "Prompt plus default response will overflow the width of the window, so be a nice guy and break it up") (|for| I |from| (- (NCHARS PROMPT) 4) |to| 10 |by| -1 |bind| (EXCESSWIDTH _ (- PROMPTWIDTH WINDOWWIDTH)) |when| (AND (EQ (NTHCHARCODE PROMPT I) (CHARCODE SPACE)) (> (STRINGWIDTH (SUBSTRING PROMPT I) PWINDOW) EXCESSWIDTH)) |do| (RETURN (SETQ PROMPT (CONCAT (SUBSTRING PROMPT 1 (SUB1 I)) (CONSTANT (CHARACTER (CHARCODE CR))) (SUBSTRING PROMPT (ADD1 I)))))))) (SETQ RESULT (CAR (NLSETQ (TTYINPROMPTFORWORD PROMPT DEFAULT NIL PWINDOW NIL 'TTY (CHARCODE (CR)))))) (WINDOWPROP PWINDOW 'PROCESS NIL) (* \;  "Get rid of process from prompt window") (COND ((AND (NULL RESULT) ABORTFLG) (PRINTOUT PWINDOW "... aborted"))) (TERPRI PWINDOW) RESULT))) (FB.YES-OR-NO-P -(LAMBDA (PROMPT FBROWSER DEFAULT) (* \; "Edited 22-Nov-88 15:30 by bvm") (* |;;| "Return Y, N or NIL, indicating whether response to question is Yes, No or some kind of abort") (LET ((ANSWER (FB.PROMPTFORINPUT PROMPT (SELECTQ DEFAULT (Y "Yes") (N "No") NIL) FBROWSER T T))) (COND ((NULL ANSWER) (* \; "Aborted") NIL) ((OR (STRING-EQUAL ANSWER "YES") (STRING-EQUAL ANSWER "Y")) (QUOTE Y)) ((OR (STRING-EQUAL ANSWER "NO") (STRING-EQUAL ANSWER "N")) (QUOTE N)) (T (FB.PROMPTWPRINT FBROWSER "?? ...Aborted.") (* \; "Confused somehow") NIL)))) -) (FB.ALLOW.ABORT -(LAMBDA (BROWSER) (* \; "Edited 4-Feb-88 23:11 by bvm:") (* |;;| "Arranges that this browser have an abort button armed. Must be called underneath a FileBrowser command, so that the cleanup in fb.make.browser.busy is enabled.") (|freplace| (FILEBROWSER UPDATEPROC) |of| (\\DTEST BROWSER (QUOTE FILEBROWSER)) |with| (THIS.PROCESS)) (LET ((W (|ffetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER))) (|if| (NOT (OPENWP (CAR W))) |then| (ATTACHWINDOW (CAR W) (CDR W) (QUOTE BOTTOM)) (* \; "And repaint it in case it was used last time") (REDISPLAYW (CAR W))))) -) (\\FB.HARDCOPY.TOFILE.EXTENSION -(LAMBDA NIL (* \; "Edited 25-Feb-91 15:15 by gadener") (LET ((TYPE (PRINTERTYPE))) (CASE TYPE (INTERPRESS (QUOTE IP)) (POSTSCRIPT (QUOTE PS)) (DEFAULT TYPE)))) -) ) (* \; "Setup") (DEFINEQ (FB.STARTUP -(LAMBDA (BROWSER COMMANDMENU FN) (* \; "Edited 21-Jan-88 17:53 by bvm") (* |;;| "Apply FN to browser with Recompute grayed out.") (RESETLST (FB.MAKE.BROWSER.BUSY BROWSER (FASSOC (QUOTE |Recompute|) (|fetch| (MENU ITEMS) |of| COMMANDMENU)) COMMANDMENU) (CL:FUNCALL FN BROWSER))) -) (FB.MAKERIGIDWINDOW -(LAMBDA (WINDOW) (* |bvm:| "22-Jul-85 16:14") (* |;;;| "make the argument window immutable w/r/to attachedwindow package") (LET ((HEIGHT (|fetch| (REGION HEIGHT) |of| (WINDOWPROP WINDOW (QUOTE REGION))))) (WINDOWPROP WINDOW (QUOTE MINSIZE) (CONS 0 HEIGHT)) (WINDOWPROP WINDOW (QUOTE MAXSIZE) (CONS SCREENWIDTH HEIGHT)) WINDOW)) -) ) (DEFINEQ (FB.PRINTFN -(LAMBDA (TBROWSER ITEM WINDOW) (* \; "Edited 30-Aug-94 19:12 by jds") (LET ((FBROWSER (TB.USERDATA TBROWSER)) (FDATA (|fetch| TIDATA |of| ITEM)) (STREAM (WINDOWPROP WINDOW (QUOTE DSP))) NEXTPOS INFO OLDFONT) (COND ((|fetch| (FBFILEDATA DIRECTORYP) |of| FDATA) (PRIN3 " " STREAM) (|if| FB.BROWSER.DIRECTORY.FONT |then| (SETQ OLDFONT (DSPFONT FB.BROWSER.DIRECTORY.FONT STREAM))))) (LET* ((FILENAME (|fetch| (FBFILEDATA FILENAME) |of| FDATA)) (OFF (|ffetch| (STRINGP OFFST) |of| FILENAME)) (BASE (|ffetch| (STRINGP BASE) |of| FILENAME)) (FATP (|ffetch| (STRINGP FATSTRINGP) |of| FILENAME)) (END (+ OFF (|ffetch| (STRINGP LENGTH) |of| FILENAME))) C) (* |;;| "This loop is a performance optimization so I don't have to cons up a substring in the display loop. This is essentially (for c instring (fetch (fbfiledata filename) of fdata) do (\\outchar stream c)), except that I want to start at STARTOFPNAME rather than 1.") (* |;;| "Slow version: (prin3 (fetch (fbfiledata printname) of fdata) stream), except it doesn't let me intercept cr's.") (|add| OFF (- (|fetch| (FBFILEDATA STARTOFPNAME) |of| FDATA) 2)) (* \; "Skip to start of name to print") (|while| (< (|add| OFF 1) END) |do| (SETQ C (COND (FATP (\\GETBASEFAT BASE OFF)) (T (\\GETBASETHIN BASE OFF)))) (\\OUTCHAR STREAM (|if| (EQ C (CHARCODE CR)) |then| (* \; "make it a blotch instead of new line #o377 is in char set 0, but is an illegal char, so can't have a glyph") 255 |else| C)))) (SETQ NEXTPOS (|fetch| (FILEBROWSER INFOSTART) |of| FBROWSER)) (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |as| INFO |in| (|fetch| (FBFILEDATA FILEINFO) |of| FDATA) |bind| (FONT _ (|fetch| (FILEBROWSER BROWSERFONT) |of| FBROWSER)) FORMAT ACTUALNEXT XPOS |do| (COND (INFO (* \; "Make sure there's always some space before next item") (PRIN3 " " STREAM))) (SETQ XPOS (DSPXPOSITION NIL STREAM)) (SETQ FORMAT (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) (SETQ ACTUALNEXT (COND ((AND (LISTP FORMAT) (FIXP INFO)) (* \; "Get numbers to line up right justified") (IMAX (- (+ NEXTPOS (CADR FORMAT)) (STRINGWIDTH INFO FONT)) XPOS)) (T (* \; "All other fields are left-justified") NEXTPOS))) (COND ((< XPOS ACTUALNEXT) (* \; "Clear any previous junk between last position and start of field") (|if| (AND INFO (EQ FORMAT (QUOTE DATE)) (EQ (CHCON1 INFO) (CHARCODE SPACE))) |then| (* \; "Small nicety for variable-width font: account for the difference between a space and a digit, so that dates line up a little better") (|add| ACTUALNEXT (- (CHARWIDTH (CHARCODE 9) FONT) (CHARWIDTH (CHARCODE SPACE) FONT)))) (TB.CLEAR.LINE TBROWSER ITEM XPOS (- ACTUALNEXT XPOS)) (DSPXPOSITION ACTUALNEXT STREAM))) (COND (INFO (PRIN3 INFO STREAM))) (|add| NEXTPOS (|fetch| (INFOFIELD INFOWIDTH) |of| SPEC))) (TB.CLEAR.LINE TBROWSER ITEM (DSPXPOSITION NIL STREAM)) (AND OLDFONT (DSPFONT OLDFONT STREAM)))) -) (FB.COPYFN -(LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (BKSYSBUF (|fetch| (FBFILEDATA FILENAME) |of| (|fetch| TIDATA |of| ITEM)))) -) ) (* \; "commands and major subfunctions") (DEFINEQ (FB.MENU.WHENSELECTEDFN -(LAMBDA (ITEM MENU KEY) (* \; "Edited 21-Jan-88 11:40 by bvm") (ADD.PROCESS (BQUOTE ((\\\, (FUNCTION FB.COMMANDSELECTEDFN)) (QUOTE (\\\, ITEM)) (QUOTE (\\\, MENU)) (QUOTE (\\\, KEY)))) (QUOTE NAME) (PACK* (QUOTE FB-) (CAR ITEM)) (QUOTE BEFOREEXIT) (QUOTE DON\'T))) -) (FB.COMMANDSELECTEDFN -(LAMBDA (ITEM MENU KEY) (* \; "Edited 12-Jan-87 12:57 by bvm:") (RESETLST (LET* ((REALITEM ITEM) (WINDOW (WINDOWPROP (WFROMMENU MENU) (QUOTE MAINWINDOW))) (FBROWSER (WINDOWPROP WINDOW (QUOTE FILEBROWSER)))) (COND ((NOT (MEMBER ITEM (|fetch| (MENU ITEMS) |of| MENU))) (* \; "A subitem -- fetch main item") (SETQ ITEM (|for| I |in| (|fetch| (MENU ITEMS) |of| MENU) |thereis| (FB.SUBITEMP ITEM I))))) (COND ((FB.MAKE.BROWSER.BUSY FBROWSER ITEM MENU) (LET ((FN (CADR REALITEM)) (PWINDOW (|fetch| (FILEBROWSER PROMPTWINDOW) |of| FBROWSER)) EXTRA) (COND ((OPENWP PWINDOW) (CLEARW PWINDOW))) (COND ((LISTP FN) (SETQ EXTRA (CADR FN)) (SETQ FN (CAR FN)))) (CL:FUNCALL FN FBROWSER KEY REALITEM MENU EXTRA))) (T (* \; "Used to be (FB.PROMPTWPRINT WINDOW 'This filebrowser is busy') but that trashes the prompt window") (FLASHWINDOW WINDOW)))))) -) (FB.SUBITEMP -(LAMBDA (SUBITEM ITEM) (* |bvm:| "22-Jul-85 15:08") (* |;;;| "True if SUBITEM appears among the subitems of ITEM or descendents") (LET ((SUB (CADDDR ITEM))) (AND SUB (EQ (CAR (LISTP SUB)) (QUOTE SUBITEMS)) (OR (MEMBER SUBITEM SUB) (|for| I |in| (CDR SUB) |thereis| (FB.SUBITEMP SUBITEM I)))))) -) (FB.MAKE.BROWSER.BUSY -(LAMBDA (BROWSER ITEM MENU DONTWAIT) (* \; "Edited 1-Feb-88 16:43 by bvm:") (* |;;;| "Makes browser 'busy' doing ITEM of MENU. Must be called under RESETLST") (COND ((OBTAIN.MONITORLOCK (|fetch| (FILEBROWSER FBLOCK) |of| BROWSER) DONTWAIT T) (RESETSAVE NIL (LIST (FUNCTION FB.FINISH.COMMAND) BROWSER ITEM MENU)) (|if| ITEM |then| (SHADEITEM ITEM MENU FB.ITEMSELECTEDSHADE)) T))) -) (FB.FINISH.COMMAND -(LAMBDA (BROWSER ITEM MENU) (* \; "Edited 1-Feb-88 16:34 by bvm:") (* |;;| "Cleanup after generic command on BROWSER. ITEM and MENU (optional) specify the shaded item. This is called under a RESETLST by anyone calling FB.MAKE.BROWSER.BUSY, but needs to be called explicitly by anyone who closes/shrinks the window before that cleanup would happen.") (|replace| (FILEBROWSER UPDATEPROC) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER ABORTING) |of| BROWSER |with| NIL) (LET ((W (CAR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER))) M) (|if| (OPENWP W) |then| (* \; "Take down the abort button if there was one") (SHADEITEM (CAR (|fetch| (MENU ITEMS) |of| (SETQ M (CAR (WINDOWPROP W (QUOTE MENU)))))) M FB.ITEMUNSELECTEDSHADE) (DETACHWINDOW W) (CLOSEW W))) (|if| ITEM |then| (SHADEITEM ITEM MENU FB.ITEMUNSELECTEDSHADE)) (COND (RESETSTATE (FB.PROMPTWPRINT BROWSER "...command aborted.")))) -) (FB.HANDLE.ABORT.BUTTON -(LAMBDA (ITEM MENU) (* \; "Edited 27-Jan-88 23:38 by bvm") (* |;;| "Called when the ABORT button on a Filebrowser is pressed.") (LET ((BROWSER (WINDOWPROP (MAINWINDOW (WFROMMENU MENU) T) (QUOTE FILEBROWSER))) PROC) (|if| (AND BROWSER (SETQ PROC (|fetch| (FILEBROWSER UPDATEPROC) |of| BROWSER)) (NOT (|fetch| (FILEBROWSER ABORTING) |of| BROWSER))) |then| (* \; "We're connected to a browser, there's a process running, and it's not already aborting") (SHADEITEM ITEM MENU FB.ITEMSELECTEDSHADE) (|replace| (FILEBROWSER ABORTING) |of| BROWSER |with| T) (DEL.PROCESS PROC)))) -) ) (DEFINEQ (FB.DELETECOMMAND -(LAMBDA (BROWSER) (* |bvm:| "12-Sep-85 15:44") (TB.MAP.SELECTED.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.DELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER)) -) (FB.DELVERCOMMAND -(LAMBDA (FBROWSER) (* \; "Edited 15-Feb-91 17:19 by gadener") (LET (NVERSIONS TBROWSER NDELETED FILES) (|if| (EQ (SETQ NVERSIONS (MENU (|create| MENU TITLE _ "Versions to keep ?" ITEMS _ FB.VERSION.MENU.ITEMS CENTERFLG _ T))) :NUMBER) |then| (FB.ALLOW.ABORT FBROWSER) (SETQ NVERSIONS (RNUMBER "Number of versions to keep ?" NIL NIL NIL T NIL T))) (COND ((NOT NVERSIONS) NIL) ((NOT (FIXP (SETQ NVERSIONS (MKATOM NVERSIONS)))) (FB.PROMPTW.FORMAT FBROWSER "~%?? ~A not an integer." NVERSIONS)) ((EQ NVERSIONS 0) NIL) (T (SETQ FILES (TB.COLLECT.ITEMS (SETQ TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER)) (FUNCTION (LAMBDA (BROWSER ITEM) (* \; "Collect everything that is not a directory item and that has an actual version (to avoid unix lossage)") (AND (NOT (|fetch| TIUNSELECTABLE |of| ITEM)) (NOT (NULL.VERSIONP (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| ITEM))))))))) (SETQ NDELETED (FB.DELVER.FILES TBROWSER (SELECTQ (|fetch| (FILEBROWSER SORTBY) |of| FBROWSER) (FB.NAMES.DECREASING.VERSION (* \; "Just right") FILES) (FB.NAMES.INCREASING.VERSION (* \; "Close, but no cigar") (FB.SORT.VERSIONS FILES (FUNCTION FB.DECREASING.VERSION))) (SORT FILES (FUNCTION FB.NAMES.DECREASING.VERSION))) NVERSIONS)) (FB.UPDATE.COUNTERS FBROWSER (QUOTE DELETED)) (FB.PROMPTW.FORMAT FBROWSER "~%Done, ~D files marked for deletion." NDELETED))))) -) (FB.IS.NOT.SUBDIRECTORY.ITEM -(LAMBDA (BROWSER ITEM) (* |bvm:| "13-Oct-85 16:51") (NOT (|fetch| TIUNSELECTABLE |of| ITEM)))) (FB.DELVER.FILES -(LAMBDA (TBROWSER FILES NVERSIONS) (* |bvm:| "15-Oct-85 00:20") (|for| FILE |in| FILES |bind| (\#DELETED _ 0) (\#SEENSOFAR _ 0) THISNAME LASTNAME |do| (* \; "Files now all lined up, decreasing version. Just pass by NVERSIONS of each file") (COND ((STRING-EQUAL (SETQ THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| FILE))) LASTNAME) (COND ((GREATERP (|add| \#SEENSOFAR 1) NVERSIONS) (COND ((FB.DELETE.FILE TBROWSER FILE) (|add| \#DELETED 1)))))) (T (SETQ LASTNAME THISNAME) (SETQ \#SEENSOFAR 1))) |finally| (RETURN \#DELETED))) -) (FB.DELETE.FILE -(LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (COND ((NOT (|fetch| TIDELETED |of| ITEM)) (LET ((FBROWSER (TB.USERDATA TBROWSER)) SIZE) (TB.DELETE.ITEM TBROWSER ITEM) (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) 1) (COND ((SETQ SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) SIZE))) T)))) -) ) (DEFINEQ (FB.UNDELETECOMMAND -(LAMBDA (BROWSER) (* |bvm:| "12-Sep-85 15:44") (TB.MAP.SELECTED.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.UNDELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER)) -) (FB.UNDELETEALLCOMMAND -(LAMBDA (BROWSER) (* |bvm:| "18-Sep-85 12:20") (TB.MAP.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.UNDELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER)) -) (FB.UNDELETE.FILE -(LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (COND ((|fetch| TIDELETED |of| ITEM) (LET ((FBROWSER (TB.USERDATA TBROWSER)) SIZE) (TB.UNDELETE.ITEM TBROWSER ITEM) (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) -1) (COND ((SETQ SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) (IMINUS SIZE)))))))) -) ) (DEFINEQ (FB.COPYCOMMAND -(LAMBDA (BROWSER) (* \; "Edited 19-Oct-90 17:44 by gadener") (FB.COPY/RENAME.COMMAND BROWSER (QUOTE |Copy|) (CONS (FUNCTION COPYFILE)))) -) (FB.RENAMECOMMAND -(LAMBDA (BROWSER) (* \; "Edited 19-Oct-90 18:57 by gadener") (FB.COPY/RENAME.COMMAND BROWSER (QUOTE |Rename|) (CONS (FUNCTION RENAMEFILE)))) -) (FB.COPY/RENAME.COMMAND -(LAMBDA (FBROWSER CMD MOVEFN) (* \; "Edited 28-Jan-88 00:27 by bvm") (LET ((*UPPER-CASE-FILE-NAMES* NIL) (FILELIST (FB.SELECTEDFILES FBROWSER))) (|if| FILELIST |then| (FB.ALLOW.ABORT FBROWSER) (COND ((CDR FILELIST) (FB.COPY/RENAME.MANY FBROWSER FILELIST CMD MOVEFN)) (T (* \; "Just one file") (LET* ((OLDNAME (FB.FETCHFILENAME (CAR FILELIST))) (NEWNAME (FB.GET.NEW.FILE.SPEC OLDNAME FBROWSER CMD))) (COND (NEWNAME (FB.COPY/RENAME.ONE FBROWSER (CAR FILELIST) OLDNAME NEWNAME CMD MOVEFN))))))))) -) (FB.COPY/RENAME.ONE -(LAMBDA (FBROWSER ITEM OLDNAME NEWNAME CMD MOVEFN) (* \; "Edited 19-Oct-90 17:50 by gadener") (* |;;;| "Copies or renames a single file ITEM from OLDNAME to NEWNAME and updates browser accordingly") (CL:MULTIPLE-VALUE-BIND (ACTUALNEWNAME CONDITION) (IGNORE-ERRORS (CL:FUNCALL (CAR MOVEFN) OLDNAME NEWNAME (CDR MOVEFN))) (COND (ACTUALNEWNAME (FB.PROMPTW.FORMAT FBROWSER "~%~A ~Aed to ~A" OLDNAME (SELECTQ CMD (|Copy| "copi") (|Rename| "renam") (SHOULDNT)) ACTUALNEWNAME) (LET ((CHANGETYPE (COND ((EQ CMD (QUOTE |Rename|)) (FB.REMOVE.FILE (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER) FBROWSER ITEM) (COND ((|fetch| TIDELETED |of| ITEM) (QUOTE BOTH)) (T (QUOTE TOTAL))))))) (COND ((FB.MAYBE.INSERT.FILE FBROWSER ACTUALNEWNAME ITEM CMD) (* \; "ACTUALNEWNAME belongs in this browser, so TOTAL may have changed") (OR CHANGETYPE (SETQ CHANGETYPE (QUOTE TOTAL))))) (COND (CHANGETYPE (FB.UPDATE.COUNTERS FBROWSER CHANGETYPE))))) (T (FB.PROMPTW.FORMAT FBROWSER "~%Could not ~(~A~) ~A ~A ~A" CMD OLDNAME (|if| CONDITION |then| "because" |else| "to") (OR CONDITION NEWNAME)))))) -) (FB.COPY/RENAME.MANY -(LAMBDA (FBROWSER FILELIST CMD MOVEFN) (* \; "Edited 22-Jan-94 20:24 by ") (PROG (PREFIX OLDNAME FIELDS SUBDIR FIRSTDATA RETAIN HOST DIR DEVICE) (COND ((NULL (SETQ PREFIX (FB.PROMPTFORINPUT (CONCAT CMD " " (LENGTH FILELIST) " files to which directory? ") (OR (|fetch| (FILEBROWSER DEFAULTDIR) |of| FBROWSER) (DIRECTORYNAME T)) FBROWSER T))) (* \; "Aborted")) ((STRPOS "*" PREFIX) (FB.PROMPTWPRINT FBROWSER "Sorry, patterns not supported")) ((AND (OR (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING PREFIX)) (QUOTE HOST)) (LISTGET FIELDS (QUOTE DIRECTORY)) (LISTGET FIELDS (QUOTE DEVICE))) (OR (LISTGET FIELDS (QUOTE NAME)) (LISTGET FIELDS (QUOTE EXTENSION)) (LISTGET FIELDS (QUOTE VERSION)))) (* \; "Not a pure directory specification, and not just a simple directory name") (FB.PROMPTWPRINT FBROWSER "Not a well-formed directory specification.")) ((SETQ PREFIX (FB.CANONICAL.DIRECTORY (\\ADD.CONNECTED.DIR PREFIX) FBROWSER CMD)) (SETQ HOST (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING PREFIX)) (QUOTE HOST))) (SETQ DIR (OR (LISTGET FIELDS (QUOTE DIRECTORY)) (LISTGET FIELDS (QUOTE RELATIVEDIRECTORY)))) (SETQ DEVICE (LISTGET FIELDS (QUOTE DEVICE))) (|replace| (FILEBROWSER DEFAULTDIR) |of| FBROWSER |with| PREFIX) (* |;;| "First scan to see if the files are in multiple subdirectories, since then it's unclear how the new files should be named.") (SETQ FIRSTDATA (|fetch| TIDATA |of| (CAR FILELIST))) (COND ((|for| ITEM |in| (CDR FILELIST) |thereis| (NOT (EQ.DIRECTORYP FIRSTDATA (|fetch| TIDATA |of| ITEM)))) (SETQ SUBDIR (|fetch| (FBFILEDATA SUBDIRECTORY) |of| FIRSTDATA)) (FB.PROMPTWPRINT FBROWSER "Selected files are in multiple subdirectories") (SETQ RETAIN (SELECTQ (FB.YES-OR-NO-P (CONCAT "Retain subdirectory names below level of " (|for| ITEM |in| (CDR FILELIST) |repeatwhile| (SETQ SUBDIR (FB.GREATEST.PREFIX SUBDIR (|fetch| (FBFILEDATA FILENAME) |of| (|fetch| TIDATA |of| ITEM)))) |finally| (RETURN (OR SUBDIR (SETQ SUBDIR (SUBSTRING (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) 1 (SUB1 (|fetch| (FILEBROWSER NAMESTART) |of| FBROWSER))))))) "?") FBROWSER (QUOTE Y)) (NIL (* \; "Aborted") (RETURN)) (Y (SETQ SUBDIR (ADD1 (NCHARS SUBDIR))) (* \; "First character that changes") T) NIL)))) (* |;;| "Now make sure the files are sorted by increasing version, so that multiple versions get copied in the right order") (SELECTQ (|fetch| (FILEBROWSER SORTBY) |of| FBROWSER) (FB.NAMES.INCREASING.VERSION (* \; "Okay")) (FB.NAMES.DECREASING.VERSION (SETQ FILELIST (FB.SORT.VERSIONS FILELIST (FUNCTION FB.INCREASING.VERSION)))) (SORT FILELIST (FUNCTION FB.NAMES.INCREASING.VERSION))) (|for| ITEM |in| FILELIST |do| (FB.COPY/RENAME.ONE FBROWSER ITEM (SETQ OLDNAME (FB.FETCHFILENAME ITEM)) (PACKFILENAME.STRING (QUOTE HOST) HOST (QUOTE DEVICE) DEVICE (QUOTE DIRECTORY) (|if| (NOT RETAIN) |then| DIR |else| (* \; "Merge destination directory with subdirectory of name between common prefix and root") (FB.MERGE.DIRECTORIES DIR (SUBSTRING OLDNAME SUBDIR (SUB1 (|fetch| (FBFILEDATA STARTOFNAME) |of| (|fetch| TIDATA |of| ITEM)))))) (QUOTE VERSION) NIL (QUOTE BODY) OLDNAME) CMD MOVEFN)))))) -) (FB.MERGE.DIRECTORIES -(LAMBDA (PREFIX RETAIN) (* \; "Edited 22-Jun-90 11:29 by nm") (COND (PREFIX (|if| RETAIN |then| (CONCAT PREFIX (CL:SECOND \\FILENAME.SYNTAX) RETAIN) |else| PREFIX)) (T (|if| RETAIN |then| RETAIN |else| NIL)))) -) (FB.GREATEST.PREFIX -(LAMBDA (DIR FILENAME) (* \; "Edited 25-Jan-88 16:37 by bvm") (* |;;;| "Greatest common directory prefix of DIR and FILENAME") (AND DIR FILENAME (COND ((STRPOS DIR FILENAME 1 NIL T NIL UPPERCASEARRAY) (* \; "DIR is prefix of FILENAME") DIR) (T (|for| I |from| 1 |bind| LASTDIR C |do| (|if| (OR (NULL (SETQ C (NTHCHARCODE DIR I))) (NEQ C (NTHCHARCODE FILENAME I))) |then| (* \; "Came to end of DIR or a non-matching character. Return the substring of DIR up to the last directory delimiter we saw.") (RETURN (AND LASTDIR (SUBSTRING DIR 1 LASTDIR))) |else| (SELCHARQ C ((/ >) (* \; "end of a subdirectory") (SETQ LASTDIR I)) NIL))))))) -) (FB.MAYBE.INSERT.FILE -(LAMBDA (FBROWSER NEWNAME OLDITEM CMD) (* \; "Edited 19-Oct-90 12:32 by gadener") (* |;;;| "If NEWNAME matches the pattern of files displayed in FBROWSER, insert it in that browser and return T. OLDITEM is the tableitem that formed the source of NEWNAME. CMD is the command that created NEWNAME -- Copy or Rename") (LET ((*UPPER-CASE-FILE-NAMES* NIL) FILEINFO N FULLNAME CRDATE CRDATE2 VERSION NEWDATA NEWITEM FILE-UNCERTAIN) (COND ((AND (DIRECTORY.MATCH (|fetch| (FILEBROWSER PREPAREDPATTERN) |of| FBROWSER) NEWNAME) (* |;;| "Need to check that at least the FB pattern is not longer than the NEWNAME") (GEQ (NCHARS NEWNAME) (SETQ N (SUB1 (|fetch| (FILEBROWSER DIRECTORYSTART) |of| FBROWSER)))) (* |;;| "Checks for match up to where the directory part start. i.e. the host part") (STRING-EQUAL NEWNAME (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) :END1 N :END2 N)) (* |;;| "NEWNAME belongs in this browser, so add it. First create some attributes for it") (SETQ NEWDATA (FB.CREATE.FILEBUCKET FBROWSER NEWNAME (SETQ FILEINFO (COND (OLDITEM (* \; "Info from old item will do for starters") (APPEND (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| OLDITEM)))) (T (|for| ATTR |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |collect| (GETFILEINFO NEWNAME (CAR ATTR)))))))) (COND ((NULL.VERSIONP (|fetch| (FBFILEDATA VERSION) |of| NEWDATA)) (* |;;| "Grumble. IFS version of Rename does not return a full file name, due to shortcoming in ftp protocol, so we won't know the version. Best we can do is assume that it's the newest version. If creation date of old file is available, verify that they agree") (|if| (NULL (SETQ FULLNAME (INFILEP NEWNAME))) |then| (* \; "Can't find file?") (SETQ FILE-UNCERTAIN T) |elseif| (NULL (SETQ VERSION (UNPACKFILENAME.STRING FULLNAME (QUOTE VERSION) NIL (QUOTE TENEX)))) |then| (* \; "Was versionless file after all, say Unix. Nothing to do. Pass TENEX as ostype because we know the name was in canonical form from device, and don't want periods turned spuriously into semi-colons") |elseif| (OR (NULL (SETQ CRDATE (CL:POSITION (QUOTE CREATIONDATE) (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER)))) (NULL (SETQ CRDATE (CL:NTH CRDATE FILEINFO))) (AND (SETQ CRDATE (IDATE CRDATE)) (SETQ CRDATE2 (GETFILEINFO FULLNAME (QUOTE ICREATIONDATE))) (= CRDATE2 CRDATE))) |then| (* \; "Assume we're right about it being newest version") (SETQ NEWDATA (FB.CREATE.FILEBUCKET FBROWSER (SETQ NEWNAME (PROGN (* \; "Canonicalize NEWNAME -- some cases where final period was left out") (PACKFILENAME.STRING (QUOTE BODY) NEWNAME (QUOTE EXTENSION) "" (QUOTE VERSION) VERSION))) FILEINFO)) |else| (SETQ FILE-UNCERTAIN T)))) (SETQ NEWITEM (|create| TABLEITEM TIDATA _ NEWDATA)) (|if| OLDITEM |then| (* \; "Update info--some is same as old file, some is new") (|for| TAIL |on| FILEINFO |as| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |unless| (SELECTQ (CAR SPEC) (AUTHOR (* \; "Rename usually preserves this, but Copy sometimes changes it") (EQ CMD (QUOTE |Rename|))) ((CREATIONDATE SIZE LENGTH TYPE BYTESIZE) (* \; "These are preserved by both copy and rename, assuming that the source and destination device are the same") T) (PROGN (* \; "Read and Write dates are generally changed. Also, conservatively assume that Copy/Rename could change any attribute we don't know about") NIL)) |do| (RPLACA TAIL (AND (NOT FILE-UNCERTAIN) (GETFILEINFO NEWNAME (CAR SPEC))))) (COND ((AND (EQ CMD (QUOTE |Rename|)) (|fetch| TISELECTED |of| OLDITEM)) (* \; "If old item was selected, keep the renamed version selected as well") (|replace| TISELECTED |of| NEWITEM |with| T)))) (FB.INSERT.FILE FBROWSER NEWITEM) T)))) -) (FB.GET.NEW.FILE.SPEC -(LAMBDA (OLDNAME BROWSER CMD) (* \; "Edited 22-Nov-88 16:55 by bvm") (* |;;| "For Copy and Rename commands, derives a new name to copy/rename to from OLDNAME. PREFIX if given is a DIRECTORY spec; if not given, we prompt for a destination file. Returns NIL if user aborts") (LET (NEWNAME NAMEFIELD FIELDS DIR) (COND ((NULL (SETQ NEWNAME (FB.PROMPTFORINPUT (CONCAT CMD " file " OLDNAME (SELECTQ CMD (|Rename| " to be: ") (|Copy| " to new file name: ") (SHOULDNT))) (PACKFILENAME.STRING (QUOTE DIRECTORY) (OR (|fetch| (FILEBROWSER DEFAULTDIR) |of| BROWSER) (DIRECTORYNAME T)) (QUOTE VERSION) NIL (QUOTE BODY) OLDNAME) BROWSER T))) (* \; "Aborted") NIL) ((NULL (SETQ NAMEFIELD (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING NEWNAME)) (QUOTE NAME)))) (* \; "Assume directory spec") (SETQ NEWNAME (\\ADD.CONNECTED.DIR NEWNAME)) (|replace| (FILEBROWSER DEFAULTDIR) |of| BROWSER |with| NEWNAME) (PACKFILENAME.STRING (QUOTE DIRECTORY) NEWNAME (QUOTE VERSION) NIL (QUOTE BODY) OLDNAME)) ((AND (EQ (NCHARS NAMEFIELD) 0) (OR (NULL (SETQ NAMEFIELD (LISTGET FIELDS (QUOTE EXTENSION)))) (EQ (NCHARS NAMEFIELD) 0))) (* \; "Directory spec with some more pieces after it?") (FB.PROMPTWPRINT BROWSER "Failed, malformed name") NIL) (T (* \; "A plain old file name") (|for| TAIL |on| FIELDS |by| (CDDR TAIL) |bind| PREVTAIL |do| (SELECTQ (CAR TAIL) ((HOST DIRECTORY DEVICE) (* \; "Keep these")) (RETURN (COND ((EQ TAIL FIELDS) (SETQ FIELDS NIL)) (T (RPLACD (CDR PREVTAIL)))))) (SETQ PREVTAIL TAIL)) (COND ((SETQ DIR (COND (FIELDS (SETQ DIR (PACKFILENAME.STRING FIELDS)) (FB.CANONICAL.DIRECTORY (COND ((NEQ (CAR FIELDS) (QUOTE HOST)) (\\ADD.CONNECTED.DIR DIR)) (T DIR)) BROWSER CMD)) (T (DIRECTORYNAME T)))) (|replace| (FILEBROWSER DEFAULTDIR) |of| BROWSER |with| DIR) (\\ADD.CONNECTED.DIR NEWNAME))))))) -) (FB.CANONICAL.DIRECTORY -(LAMBDA (DIRNAME FBROWSER CMD) (* \; "Edited 22-Nov-88 16:58 by bvm") (LET* ((PWINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST FBROWSER (QUOTE FILEBROWSER)))) (OLDTTYSTREAM (TTYDISPLAYSTREAM PWINDOW)) (OLDTTYPROC (TTY.PROCESS (THIS.PROCESS)))) (* \; "Point tty at our prompt window in case DIRECTORYNAME tries to interact") (CL:UNWIND-PROTECT (COND ((DIRECTORYNAME DIRNAME NIL (QUOTE ASK))) ((EQ (FB.YES-OR-NO-P (CL:FORMAT NIL "Directory ~A does not exist yet; ~A anyway?" DIRNAME CMD) FBROWSER) (QUOTE Y)) DIRNAME)) (TTY.PROCESS OLDTTYPROC) (TTYDISPLAYSTREAM OLDTTYSTREAM) (WINDOWPROP PWINDOW (QUOTE PROCESS) NIL)))) -) ) (DEFINEQ (FB.HARDCOPYCOMMAND -(LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \; "Edited 18-Feb-91 10:44 by gadener") (* |;;;| "Produces hardcopy of selected files. Subcommands allow directing output to particular printer, or to a file") (LET ((FILES (FB.SELECTEDFILES BROWSER)) PRINTOPTIONS) (COND ((AND FILES (SELECTQ OPTION (FILE (FB.ALLOW.ABORT BROWSER) (FB.HARDCOPY.TOFILE BROWSER FILES) NIL) (PRINTER (COND ((SETQ PRINTOPTIONS (|GetPrinterName|)) (SETQ PRINTOPTIONS (LIST (QUOTE SERVER) PRINTOPTIONS)) T))) T)) (FB.ALLOW.ABORT BROWSER) (|for| ITEM |in| FILES |do| (LISTFILES1 (FB.FETCHFILENAME ITEM) PRINTOPTIONS)))))) -) (FB.HARDCOPY.TOFILE -(LAMBDA (BROWSER FILES) (* \; "Edited 15-Feb-91 17:13 by gadener") (* |;;| "Handle the \"Hardcopy>To File\" command. ") (PROG ((HCOPYFILE (FB.PROMPTFORINPUT (COND ((CDR FILES) "Hardcopy file name pattern: ") (T "Hardcopy file name: ")) (COND ((CDR FILES) (PACKFILENAME.STRING (QUOTE NAME) (QUOTE *) (QUOTE EXTENSION) (\\FB.HARDCOPY.TOFILE.EXTENSION))) (T (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE EXTENSION) (\\FB.HARDCOPY.TOFILE.EXTENSION) (QUOTE BODY) (FB.FETCHFILENAME (CAR FILES))))) BROWSER T)) HCOPYFIELDS PRINTFILETYPE MSG HCOPYTAIL FORE AFT EXT) (COND ((NULL HCOPYFILE) (RETURN))) (COND ((CDR FILES) (* |;;| "Hardcopying multiple files. Take apart the pattern so we can figure out how to make the destination names. We insist that the * be in the name.") (COND ((|for| TAIL |on| (SETQ HCOPYFIELDS (UNPACKFILENAME.STRING HCOPYFILE)) |by| (CDDR TAIL) |bind| HOST HAVEDIRECTORY I |do| (COND ((SETQ I (STRPOS (QUOTE *) (CADR TAIL))) (|if| (NEQ (CAR TAIL) (QUOTE NAME)) |then| (RETURN (SETQ MSG "Only name portion can contain *"))) (* \; "Take apart name into FORE*AFT") (SETQ HCOPYTAIL (CDR TAIL)) (SETQ FORE (OR (SUBSTRING (CADR TAIL) 1 (SUB1 I)) "")) (SETQ AFT (OR (SUBSTRING (CADR TAIL) (ADD1 I)) ""))) (T (SELECTQ (CAR TAIL) (NAME (RETURN (SETQ MSG "Name must have * for multiple hardcopy files"))) (EXTENSION (SETQ EXT (MKATOM (U-CASE (CADR TAIL))))) (DIRECTORY (SETQ HAVEDIRECTORY T)) (HOST (SETQ HOST (CADR TAIL))) NIL))) |finally| (|if| (AND HOST (NOT HAVEDIRECTORY)) |then| (* \; "E.g., {DSK}*.IP. This pattern explicitly has no directory") (|push| HCOPYFIELDS (QUOTE DIRECTORY) NIL))) (FB.PROMPTWPRINT BROWSER "Bad pattern -- " MSG) (RETURN)))) (T (SETQ EXT (U-CASE (FILENAMEFIELD HCOPYFILE (QUOTE EXTENSION)))))) (COND ((AND (NULL (SETQ PRINTFILETYPE (|for| TYPE |in| PRINTFILETYPES |when| (FMEMB EXT (CADR (ASSOC (QUOTE EXTENSION) (CDR TYPE)))) |do| (* \; "Opencoded PRINTFILETYPE.FROM.EXTENSION because that one's buggy") (RETURN (CAR TYPE))))) (NULL (SETQ PRINTFILETYPE (MENU (|MakeMenuOfImageTypes| "File type?"))))) (RETURN))) (|for| ITEM |in| FILES |bind| (CONVERTERS _ (PRINTFILEPROP PRINTFILETYPE (QUOTE CONVERSION))) FILETYPE NAME FN FIELDS |do| (SETQ ITEM (FB.FETCHFILENAME ITEM)) (SETQ FILETYPE (OR (PRINTFILETYPE ITEM) (QUOTE TEXT))) (COND ((SETQ FN (LISTGET CONVERTERS FILETYPE)) (FB.PROMPTW.FORMAT BROWSER "~%Writing ~A..." (SETQ NAME (COND ((CDR FILES) (SETQ FIELDS (UNPACKFILENAME.STRING ITEM NIL NIL (QUOTE TENEX))) (RPLACA HCOPYTAIL (CONCAT FORE (LISTGET FIELDS (QUOTE NAME)) AFT)) (CL:APPLY (FUNCTION PACKFILENAME.STRING) (QUOTE VERSION) NIL (APPEND HCOPYFIELDS FIELDS))) (T HCOPYFILE)))) (SETQ NAME (CL:FUNCALL FN ITEM NAME)) (COND ((LISTP NAME) (* \; "Result is (SOURCE DESTINATION)") (SETQ NAME (CADR NAME)))) (FB.PROMPTWPRINT BROWSER "done.") (FB.MAYBE.INSERT.FILE BROWSER NAME)) (T (FB.PROMPTW.FORMAT BROWSER "~%Failed to hardcopy ~A -- Can't convert a ~A file to format ~A" ITEM FILETYPE PRINTFILETYPE)))))) -) ) (DEFINEQ (FB.EDITCOMMAND -(LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \; "Edited 1-Feb-88 19:00 by bvm:") (FB.ALLOW.ABORT BROWSER) (|for| FILE |in| (FB.SELECTEDFILES BROWSER) |bind| (*UPPER-CASE-FILE-NAMES* _ NIL) |do| (SETQ FILE (FB.FETCHFILENAME FILE)) (CL:MULTIPLE-VALUE-BIND (IGNORE CONDITION) (IGNORE-ERRORS (SELECTQ (OR OPTION FB.DEFAULT.EDITOR) (READONLY (* \; "From SEE command") (COND ((NOT (GETD (QUOTE OPENTEXTSTREAM))) (FB.FASTSEECOMMAND BROWSER KEY ITEM MENU)) (T (RESETLST (LET ((WINDOW (CREATEW NIL FILE)) (STR (OPENSTREAM FILE (QUOTE INPUT)))) (COND ((LISPSOURCEFILEP STR) (RESETSAVE NIL (LIST (QUOTE CLOSEF) STR)) (SETQ STR (LET ((NSTR (OPENTEXTSTREAM))) (COPY.TEXT.TO.IMAGE STR NSTR) NSTR))) ((NOT (RANDACCESSP STR)) (RESETSAVE NIL (LIST (QUOTE CLOSEF) STR)) (SETQ STR (LET ((NSTR (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH) (QUOTE NEW) NIL (LIST (LIST (QUOTE TYPE) (GETFILEINFO STR (QUOTE TYPE))))))) (COPYBYTES STR NSTR) NSTR)))) (OPENTEXTSTREAM STR WINDOW NIL NIL (QUOTE (READONLY T)))))))) (TEDIT (TEDIT (MKATOM FILE))) (LISP (FB.EDITLISPFILE FILE BROWSER)) (NIL (COND ((LISPSOURCEFILEP FILE) (FB.EDITLISPFILE FILE BROWSER)) (T (TEDIT (MKATOM FILE))))) (CL:FUNCALL OPTION (MKATOM FILE)))) (|if| CONDITION |then| (FB.PROMPTW.FORMAT BROWSER "Failed because ~A" CONDITION))))) -) (FB.EDITLISPFILE -(LAMBDA (FILE BROWSER) (* \; "Edited 28-Jan-88 00:38 by bvm") (PROG (ROOT) (COND ((OR (NOT (STRING-EQUAL (CDAR (GETPROP (SETQ ROOT (U-CASE (ROOTFILENAME FILE))) (QUOTE FILEDATES))) FILE)) (NOT (GET ROOT (QUOTE FILE))) (NOT (BOUNDP (FILECOMS ROOT)))) (COND ((MOUSECONFIRM (CONCAT "The file " FILE " is not loaded or is not current. (LOAD '" FILE " 'PROP)?") NIL (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER)) (EXEC-EVAL (BQUOTE (LOAD (QUOTE (\\\, FILE)) (QUOTE PROP))))) (T (RETURN))))) (RESETFORM (TTYDISPLAYSTREAM PROMPTWINDOW) (ED ROOT (QUOTE (FILES :DONTWAIT)))))) -) (FB.BROWSECOMMAND -(LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \; "Edited 1-Feb-88 18:31 by bvm:") (* |;;;| "view selected file by sprouting a recursive file browser on it") (FB.ALLOW.ABORT BROWSER) (|for| FILE |in| (FB.SELECTEDFILES BROWSER) |bind| (DEPTH _ (|fetch| (FILEBROWSER FBDEPTH) |of| BROWSER)) NAME |do| (SETQ FILE (|fetch| TIDATA |of| FILE)) (SETQ NAME (|fetch| (FBFILEDATA FILENAME) |of| FILE)) (|if| (OR (|fetch| (FBFILEDATA DIRECTORYFILEP) |of| FILE) (AND (NOT (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER)) (LET* ((FIELDS (UNPACKFILENAME.STRING NAME NIL NIL (QUOTE TENEX))) (NAMETAIL (MEMB (QUOTE NAME) FIELDS)) INTERESTING SUBDIR MAINDIR) (* \; "File is not syntactically a directory. Perhaps the device returned foo.;1 instead of foo>. We know ns servers don't do this.") (|for| TAIL |on| NAMETAIL |by| (CDDR TAIL) |do| (|if| (OR (EQ 0 (NCHARS (CADR TAIL))) (AND (EQ (CAR TAIL) (QUOTE VERSION)) (|if| (NEQ (MKATOM (CADR TAIL)) 1) |then| (* \; "It has a version--most unlikely for a directory") (RETURN NIL) |else| T))) |then| (* \; "turn empty or boring fields into omitted fields") (RPLACA (CDR TAIL) NIL) |else| (SETQ INTERESTING T)) |finally| (SETQ FIELDS (LDIFF FIELDS NAMETAIL)) (|if| INTERESTING |then| (* |;;| "Would like just to do (CL:APPLY (function packfilename.string) (nconc fields `(SUBDIRECTORY subdir))), but PACKFILENAME.STRING doesn't seem to know about unix.") (SETQ MAINDIR (LISTGET FIELDS (QUOTE DIRECTORY))) (SETQ SUBDIR (CL:APPLY (FUNCTION PACKFILENAME.STRING) NAMETAIL)) (LISTPUT FIELDS (QUOTE DIRECTORY) (|if| (NULL MAINDIR) |then| SUBDIR |else| (CONCAT MAINDIR (|if| (STRPOS "/" MAINDIR) |then| "/" |elseif| (STRPOS ">" MAINDIR) |then| ">" |elseif| (EQ (GETHOSTINFO (LISTGET FIELDS (QUOTE HOST)) (QUOTE OSTYPE)) (QUOTE UNIX)) |then| (* \; "Resort to GETHOSTINFO only if the name hasn't given it away yet.") "/" |else| ">") SUBDIR)))) (RETURN (DIRECTORYNAMEP (SETQ NAME (CL:APPLY (FUNCTION PACKFILENAME.STRING) FIELDS)))))))) |then| (ADD.PROCESS (BQUOTE ((\\\, (FUNCTION FILEBROWSER)) (QUOTE (\\\, NAME)) (QUOTE (\\\, (MAPCAR (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER) (FUNCTION CAR)))) (\\\,@ (AND DEPTH (BQUOTE ((QUOTE (:DEPTH (\\\, DEPTH)))))))))) |else| (FB.PROMPTW.FORMAT BROWSER "~A is not a directory" NAME)))) -) ) (DEFINEQ (FB.FASTSEECOMMAND -(LAMBDA (BROWSER KEY ITEM MENU UNFORMATTED) (* \; "Edited 30-Aug-94 19:46 by jds") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) FILELIST SEEWINDOW) (OR (SETQ FILELIST (FB.SELECTEDFILES BROWSER)) (RETURN)) (FB.ALLOW.ABORT BROWSER) (COND ((AND (NOT (WINDOWP (SETQ SEEWINDOW (|fetch| (FILEBROWSER SEEWINDOW) |of| BROWSER)))) (FOR FILE IN FILELIST THEREIS (* |;;| "Only need a SEE window if there's going to be a file to really SEE, as opposed to directories to browse.") (OR (UNPACKFILENAME (FB.FETCHFILENAME FILE) (QUOTE NAME)) (UNPACKFILENAME (FB.FETCHFILENAME FILE) (QUOTE EXTENSION))))) (* \; "Create the SEE window") (SETQ SEEWINDOW (CREATEW NIL "SEE window")) (DSPSCROLL T SEEWINDOW) (|replace| (FILEBROWSER SEEWINDOW) |of| BROWSER |with| SEEWINDOW) (WINDOWPROP SEEWINDOW (QUOTE PAGEFULLFN) (FUNCTION FB.SEEFULLFN)) (WINDOWADDPROP SEEWINDOW (QUOTE CLOSEFN) (FUNCTION (LAMBDA (W) (WINDOWPROP W (QUOTE INUSE) NIL) (DEL.PROCESS (WINDOWPROP W (QUOTE PROCESS)))))))) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (WINDOW) (WINDOWPROP WINDOW (QUOTE PROCESS) NIL) (* \; "Remove process attached here by ttydisplaystream") (LET ((BUTTONS (WINDOWPROP WINDOW (WINDOWPROP WINDOW (QUOTE MORETYPE))))) (|if| (AND BUTTONS (OPENWP BUTTONS)) |then| (* \; "If More button still open, detach it") (DETACHWINDOW BUTTONS) (CLOSEW BUTTONS))))) SEEWINDOW)) (TTYDISPLAYSTREAM SEEWINDOW) (* \; "Has to be our TTYDISPLAYSTREAM in order for page holding to work") (|for| TAIL |on| FILELIST |do| (CL:CATCH :NEXT (FB.FASTSEE.ONEFILE BROWSER (FB.FETCHFILENAME (CAR TAIL)) SEEWINDOW UNFORMATTED (CDR TAIL)))))) -) (FB.FASTSEE.ONEFILE (LAMBDA (BROWSER FILE WINDOW UNFORMATTED MORE) (* \;  "Edited 20-Nov-2000 14:24 by rmk:") (* \;  "Edited 20-Nov-2000 14:23 by rmk:") (* \; "Edited 19-Aug-91 13:06 by jds") (COND ((OR (UNPACKFILENAME FILE 'NAME) (UNPACKFILENAME FILE 'EXTENSION)) (* |;;| "We're really browsing a file here, so SEE it.") (CLEARW WINDOW) (WINDOWPROP WINDOW 'TITLE (CONCAT "Viewing " FILE)) (CL:MULTIPLE-VALUE-BIND (STREAM CONDITION) (IGNORE-ERRORS (OPENSTREAM FILE 'INPUT NIL '((TYPE TEXT) (SEQUENTIAL T)))) (|if| CONDITION |then| (* |;;| "Failed on this file. If this was the only file, the message can be a little more terse (which is desirable, because the typical message is \"File not found xxx\")") (FB.PROMPTW.FORMAT BROWSER "~:[Failed~;~:*Couldn't see ~A~] because ~A" (AND MORE FILE) CONDITION) |else| (RESETLST (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (STREAM WINDOW) (AND RESETSTATE (OPENWP WINDOW) (WINDOWPROP WINDOW 'TITLE (CONCAT (WINDOWPROP WINDOW 'TITLE) " -- " "Aborted"))) (CLOSEF STREAM))) STREAM WINDOW)) (WINDOWPROP WINDOW 'MORETYPE (COND (MORE 'YETMOREBUTTONS) (T 'LASTMOREBUTTONS))) (COND (UNFORMATTED (COPYCHARS STREAM WINDOW)) (T (PFCOPYBYTES STREAM WINDOW))) (WINDOWPROP WINDOW 'TITLE (CONCAT (WINDOWPROP WINDOW 'TITLE) " -- " "Finished")) (COND (MORE (* \; "Wait for OK to proceed") (FB.SEEFULLFN (WINDOWPROP WINDOW 'DSP) 'FINISHEDMOREBUTTONS))))))) (T (* |;;| "We're trying to SEE a directory. Browse it instead. ") (FB.BROWSECOMMAND BROWSER))))) (FB.SEEFULLFN -(LAMBDA (DSP PROP) (* |bvm:| "18-Sep-85 23:29") (* |;;| "PAGEFULLFN for a fast SEE window") (LET* ((WINDOW (WFROMDS DSP)) (BUTTONS (WINDOWPROP WINDOW (OR PROP (SETQ PROP (WINDOWPROP WINDOW (QUOTE MORETYPE)))))) (EVENT (WINDOWPROP WINDOW (QUOTE MOREEVENT)))) (COND ((NOT BUTTONS) (SETQ BUTTONS (|create| MENU ITEMS _ (SELECTQ PROP (YETMOREBUTTONS (QUOTE (("More" MORE "View another screenfull of the file") (" Next File " NEXT "Abort view of this file, go on to next one") ("Abort" ABORT "Abort viewing of this and any further files")))) (FINISHEDMOREBUTTONS (QUOTE ((" Next File " NEXT "Go on to view the next file") ("Abort" ABORT "Abort the SEE command -- see no more files")))) (QUOTE ((" More " MORE "View another screenfull of the file") (" Abort " ABORT "Abort view; allow this window to be re-used")))) MENUROWS _ 1 WHENSELECTEDFN _ (FUNCTION FB.SEEBUTTONFN) CENTERFLG _ T)) (SETQ BUTTONS (ADDMENU BUTTONS (CREATEW (CREATEREGION 0 0 (WIDTHIFWINDOW (|fetch| (MENU IMAGEWIDTH) |of| BUTTONS) FB.MORE.BORDER) (HEIGHTIFWINDOW (|fetch| (MENU IMAGEHEIGHT) |of| BUTTONS) NIL FB.MORE.BORDER)) NIL FB.MORE.BORDER T) NIL T)) (WINDOWPROP WINDOW PROP BUTTONS))) (COND ((NOT EVENT) (WINDOWPROP WINDOW (QUOTE MOREEVENT) (SETQ EVENT (CREATE.EVENT (WINDOWPROP WINDOW (QUOTE TITLE))))))) (ATTACHWINDOW BUTTONS WINDOW (COND ((GREATERP (|fetch| (REGION HEIGHT) |of| (WINDOWPROP BUTTONS (QUOTE REGION))) (|fetch| (REGION BOTTOM) |of| (WINDOWPROP WINDOW (QUOTE REGION)))) (QUOTE TOP)) (T (QUOTE BOTTOM))) (QUOTE LEFT)) (|do| (TOTOPW BUTTONS) (AWAIT.EVENT EVENT) |repeatuntil| (WINDOWPROP WINDOW (QUOTE MOREOK) NIL)))) -) (FB.SEEBUTTONFN -(LAMBDA (ITEM MENU) (* \; "Edited 28-Jan-88 00:05 by bvm") (* |;;;| "WHENSELECTEDFN for the More/Abort menu") (LET* ((MENUW (WFROMMENU MENU)) (WINDOW (MAINWINDOW MENUW))) (DETACHWINDOW MENUW) (* \; "Take the buttons down") (CLOSEW MENUW) (SELECTQ (CADR ITEM) (MORE (* \; "Notify pagefullfn that it can continue") (WINDOWPROP WINDOW (QUOTE MOREOK) T) (NOTIFY.EVENT (WINDOWPROP WINDOW (QUOTE MOREEVENT)))) (NEXT (* \; "Throw to the loop that is displaying each file") (PROCESS.EVAL (WINDOWPROP WINDOW (QUOTE PROCESS)) (QUOTE (CL:THROW :NEXT)))) (ABORT (* \; "Kill it") (DEL.PROCESS (WINDOWPROP WINDOW (QUOTE PROCESS)))) (SHOULDNT)))) -) ) (DEFINEQ (FB.LOADCOMMAND -(LAMBDA (BROWSER KEY ITEM MENU LOADOP) (* |bvm:| "18-Sep-85 17:16") (LET ((FILES (FB.SELECTEDFILES BROWSER))) (AND FILES (ADD.PROCESS (LIST (FUNCTION FB.OPERATE.ON.FILES) (KWOTE (OR LOADOP (FUNCTION LOAD))) (KWOTE FILES)) (QUOTE NAME) (QUOTE LOAD) (QUOTE BEFOREEXIT) (QUOTE DON\'T))))) -) (FB.COMPILECOMMAND -(LAMBDA (BROWSER KEY ITEM MENU COMPILEOP) (* \; "Edited 5-Mar-87 17:39 by bvm:") (LET ((FILES (FB.SELECTEDFILES BROWSER))) (AND FILES (ADD.PROCESS (LIST (FUNCTION FB.OPERATE.ON.FILES) (KWOTE (OR COMPILEOP *DEFAULT-CLEANUP-COMPILER*)) (KWOTE FILES)) (QUOTE NAME) (QUOTE COMPILE) (QUOTE BEFOREEXIT) (QUOTE DON\'T))))) -) (FB.OPERATE.ON.FILES -(LAMBDA (FN FILELIST) (* \; "Edited 4-Feb-88 15:14 by bvm:") (LET (LDFLG FORMS) (SELECTQ FN ((PROP SYSLOAD) (SETQ LDFLG FN) (SETQ FN (QUOTE LOAD))) NIL) (SETQ FORMS (|for| FILEENTRY |in| FILELIST |collect| (BQUOTE ((\\\, FN) (QUOTE (\\\, (FB.FETCHFILENAME FILEENTRY))) (\\\,@ (AND LDFLG (BQUOTE ((QUOTE (\\\, LDFLG)))))))))) (EXEC-EVAL (|if| (CDR FORMS) |then| (CONS (QUOTE PROGN) FORMS) |else| (CAR FORMS))) (CLOSEW (TTYDISPLAYSTREAM)))) -) ) (DEFINEQ (FB.UPDATECOMMAND -(LAMBDA (BROWSER) (* |bvm:| "27-Sep-85 12:30") (COND ((FB.MAYBE.EXPUNGE BROWSER (QUOTE |Recompute|)) (FB.UPDATEBROWSERITEMS BROWSER)))) -) (FB.MAYBE.EXPUNGE -(LAMBDA (BROWSER COMMAND) (* |bvm:| "27-Sep-85 12:30") (* |;;;| "If BROWSER has files marked for deletion, ask whether user wants to expunge them. Returns T if it is okay to proceed, NIL if not (user aborted or expunge failed)") (COND ((EQ (|fetch| (FILEBROWSER DELETEDFILES) |of| BROWSER) 0) T) (T (FB.PROMPTWPRINT BROWSER "Some files are marked for deletion. -Do you want to expunge them first?") (SELECTQ (MENU (FB.EXPUNGE?.MENU)) (EXPUNGE (* \; "Do expunge in another process, not here in mouse") (FB.EXPUNGECOMMAND BROWSER NIL NIL NIL COMMAND)) (NOEXPUNGE T) NIL)))) -) (FB.UPDATEBROWSERITEMS -(LAMBDA (BROWSER) (* \; "Edited 30-Aug-94 19:46 by jds") (RESETLST (PROG ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (FONT FB.BROWSERFONT) PATTERN INFOWANTED FILEGENERATOR FILENAME NOW INDEX WIDENED CONDITION) (FB.ALLOW.ABORT BROWSER) (COND ((SETQ PATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER))) ((SETQ PATTERN (FB.GET.NEWPATTERN BROWSER)) (* \; "Didn't have a pattern before--got one now") (FB.SETNEWPATTERN BROWSER PATTERN)) (T (* \; "Refused to give me a pattern") (RETURN))) (PROGN (* \; "Restore browser to empty state--clear the counter window, set the title, remove any items, reset counters.") (|replace| (FILEBROWSER INFODISPLAYED) |of| BROWSER |with| (SETQ INFOWANTED (|for| SPEC |in| FB.INFO.FIELDS |bind| (WANTED _ (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER)) W PROTO |when| (MEMB (|fetch| (INFOFIELD INFONAME) |of| SPEC) WANTED) |collect| (SETQ SPEC (COPY SPEC)) (|if| (SETQ PROTO (|fetch| (INFOFIELD INFOPROTOTYPE) |of| SPEC)) |then| (* \; "Have prototypical example, use it to get better width estimate.") (SETQ W (STRINGWIDTH PROTO FONT)) (|replace| (INFOFIELD INFOWIDTH) |of| SPEC |with| (+ W (TIMES 2 (CHARWIDTH (CHARCODE X) FONT)))) (|if| (LISTP (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) |then| (RPLACA (CDR (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) W))) SPEC))) (FB.SET.BROWSER.TITLE BROWSER) (CLEARW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER)) (CLEARW (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (* \; "Clear header window in case it has been scrolled.") (TB.REPLACE.ITEMS TBROWSER NIL) (|replace| (FILEBROWSER FBREADY) |of| BROWSER |with| NIL) (TB.SET.FONT TBROWSER FONT) (|replace| (FILEBROWSER BROWSERFONT) |of| BROWSER |with| FONT) (FB.SET.DEFAULT.NAME.WIDTH BROWSER) (|replace| (FILEBROWSER DELETEDFILES) |of| BROWSER |with| (|replace| (FILEBROWSER DELETEDPAGES) |of| BROWSER |with| (|replace| (FILEBROWSER TOTALPAGES) |of| BROWSER |with| (|replace| (FILEBROWSER TOTALFILES) |of| BROWSER |with| 0)))) (|replace| (FILEBROWSER SORTMENU) |of| BROWSER |with| (|replace| (FILEBROWSER PATTERNPARSED?) |of| BROWSER |with| NIL))) (|if| (SETQ INDEX (OR (CL:POSITION (QUOTE SIZE) INFOWANTED :KEY (FUNCTION CAR)) (CL:POSITION (QUOTE LENGTH) INFOWANTED :KEY (FUNCTION CAR)))) |then| (|replace| (FILEBROWSER SIZEINDEX) |of| BROWSER |with| INDEX)) (|replace| (FILEBROWSER PAGECOUNT?) |of| BROWSER |with| (AND INDEX (CAR (CL:NTH INDEX INFOWANTED)))) (PROGN (|replace| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER SORTBY) |of| BROWSER |with| (FUNCTION FB.NAMES.DECREASING.VERSION))) (CL:MULTIPLE-VALUE-SETQ (FILEGENERATOR CONDITION) (IGNORE-ERRORS (LET* ((DESIREDPROPS (MAPCAR INFOWANTED (FUNCTION CAR))) (NSP (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER)) (DEPTH (OR (|fetch| (FILEBROWSER FBDEPTH) |of| BROWSER) (|if| NSP |then| (* \; "FILING.ENUMERATION.DEPTH is significant for NS servers") FILING.ENUMERATION.DEPTH))) (FILING.ENUMERATION.DEPTH (OR DEPTH FILING.ENUMERATION.DEPTH))) (DECLARE (SPECVARS FILING.ENUMERATION.DEPTH)) (FB.PROMPTW.FORMAT BROWSER "~%Enumerating ~A ~@[to depth ~D ~]..." PATTERN (FIXP DEPTH)) (|if| (AND NSP (|fetch| (FILEBROWSER PAGECOUNT?) |of| BROWSER) (OR DEPTH (NOT (UNPACKFILENAME.STRING PATTERN (QUOTE DIRECTORY))))) |then| (* \; "Ask for SUBTREE.SIZE also, so we can give page estimates of subdirectories, or in the case of enumerating a host, the top-level directories") (|push| DESIREDPROPS (QUOTE SUBTREE.SIZE))) (|replace| (FILEBROWSER FBDISPLAYEDDEPTH) |of| BROWSER |with| (|replace| (FILEBROWSER FBCOMPUTEDDEPTH) |of| BROWSER |with| (OR (FIXP DEPTH) 0))) (\\GENERATEFILES PATTERN DESIREDPROPS (QUOTE (SORT RESETLST)))))) (|if| CONDITION |then| (FB.PROMPTW.FORMAT BROWSER "Failed because ~A" CONDITION) (RETURN)) (SETQ NOW (FB.DATE)) (* \; "Time as of which the enumeration is reasonably valid") (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (|while| (SETQ FILENAME (\\GENERATENEXTFILE FILEGENERATOR)) |bind| LASTFILEDATA NEWFILEDATA PREVGROUPDATA OTHERFILES |do| (* |;;| "For each file, create an FBFILEDATA object. Gather together files with the same name, different version, so that we can sort versions. Thus, the display is always (at least) one file behind the generator: LASTFILEDATA is the first item of a given name, OTHERFILES are the remaining versions. PREVGROUPDATA is representative of the previous group.") (COND ((LISTP FILENAME) (* \; "Old kind of generator. Extinct?") (SETQ FILENAME (CONCATCODES FILENAME)))) (SETQ NEWFILEDATA (FB.CREATE.FILEBUCKET BROWSER FILENAME (FB.GETALLFILEINFO BROWSER FILEGENERATOR INFOWANTED) LASTFILEDATA)) (COND ((AND LASTFILEDATA (EQ (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| LASTFILEDATA) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| NEWFILEDATA))) (* \; "This file same name as previous one, so save it in case we need to sort versions. Note that FB.CREATE.FILEBUCKET canonicalizes the VERSIONLESSNAME, so EQ suffices") (|push| OTHERFILES NEWFILEDATA)) (T (COND ((AND LASTFILEDATA (OR (NOT (|fetch| (FBFILEDATA DIRECTORYFILEP) |of| LASTFILEDATA)) (NOT (STRPOS (|fetch| (FBFILEDATA FILENAME) |of| LASTFILEDATA) (|fetch| (FBFILEDATA FILENAME) |of| NEWFILEDATA) 1 NIL T NIL UPPERCASEARRAY)))) (* |;;| "Add the previous group we have accumulated. Second clause says not to add a line for a subdirectory file which is not a leaf, i.e., for which there are files below it in the enumeration (it would be nice if NS filing did this filtering itself).") (FB.ADD.FILEGROUP TBROWSER BROWSER LASTFILEDATA OTHERFILES PREVGROUPDATA) (SETQ PREVGROUPDATA LASTFILEDATA))) (SETQ OTHERFILES NIL) (SETQ LASTFILEDATA NEWFILEDATA))) |finally| (AND LASTFILEDATA (FB.ADD.FILEGROUP TBROWSER BROWSER LASTFILEDATA OTHERFILES PREVGROUPDATA))) (COND ((EQ (TB.NUMBER.OF.ITEMS TBROWSER) 0) (FB.PROMPTWPRINT BROWSER (QUOTE CLEAR) "No files in group " PATTERN)) (T (FB.PROMPTWPRINT BROWSER (QUOTE |done|)) (SETQ WIDENED (FB.MAYBE.WIDEN.NAMES BROWSER)) (COND ((OR (FB.ADJUST.DATE.WIDTH BROWSER INFOWANTED) WIDENED) (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (TB.REDISPLAY.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)))))) (FB.SET.BROWSER.TITLE BROWSER NOW) (|replace| (FILEBROWSER FBREADY) |of| BROWSER |with| T) (FB.DISPLAY.COUNTERS BROWSER)))) -) (FB.DATE -(LAMBDA NIL (* \; "Edited 21-Jan-88 18:40 by bvm") (LET ((DT (DATE (DATEFORMAT DAY.OF.WEEK DAY.SHORT NO.SECONDS)))) (* |;;| "DT is in the form \"dd-mon-yy hh:mm (day)\". Turn it into \"hh:mm day dd-mon-yy\".") (CONCAT (SUBSTRING DT 11 16) (SUBSTRING DT 18 20) " " (SUBSTRING DT (|if| (EQ (CHCON1 DT) (CHARCODE SPACE)) |then| (* \; "Trim leading space from date") 2 |else| 1) 9)))) -) (FB.ADJUST.DATE.WIDTH -(LAMBDA (BROWSER INFOWANTED) (* \; "Edited 30-Aug-94 19:40 by jds") (* |;;| "Adjust the expected with field of any date fields (other than the last) to reflect the width of actual dates this device returns. Returns T if it did anything.") (|for| TAIL |on| INFOWANTED |as| INDEX |from| 0 |while| (CDR TAIL) |bind| (FONT _ (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER)) SPEC RESULT |when| (AND (EQ (|fetch| (INFOFIELD INFOFORMAT) |of| (SETQ SPEC (CAR TAIL))) (QUOTE DATE)) (TB.FIND.ITEM (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION (LAMBDA (TBROWSER ITEM) (|if| (SETQ ITEM (CL:NTH INDEX (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| ITEM)))) |then| (* |;;| "Got a sample date. Assuming all dates have the same number of characters, compute a width that fits this date plus a couple spaces. Computation here for variable-width font assumes \"MAY\" is about as wide as you get, and finesses the issue of whether this date happens to start with leading space and/or contain some especially skinny letters.") (|replace| (INFOFIELD INFOWIDTH) |of| SPEC |with| (+ (STRINGWIDTH "XX99-MAY-88 99:99:99" FONT) (|if| (> (NCHARS ITEM) 18) |then| (* \; "Have a time-zone, too, or something") (STRINGWIDTH (SUBSTRING ITEM 19) FONT) |else| 0))) T))))) |do| (SETQ RESULT T) |finally| (RETURN RESULT))) -) (FB.SET.BROWSER.TITLE -(LAMBDA (BROWSER TIME) (* \; "Edited 21-Jan-88 18:37 by bvm") (* |;;| "(Re)display the title on BROWSER's window. If Time is supplied, it is the time at which the enumeration happened, and we include it in the title. Title is not changed if user supplied own title.") (COND ((NOT (|fetch| (FILEBROWSER FIXEDTITLE) |of| BROWSER)) (WINDOWPROP (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER) (QUOTE TITLE) (|if| TIME |then| (CONCAT (|fetch| (FILEBROWSER PATTERN) |of| BROWSER) " at " TIME) |else| (CONCAT (|fetch| (FILEBROWSER PATTERN) |of| BROWSER) " browser")))))) -) (FB.MAYBE.WIDEN.NAMES -(LAMBDA (BROWSER) (* |bvm:| "18-Oct-85 17:32") (* |;;;| "Examines the OVERFLOWWIDTHS field to see if we should widen the name area of the browser, shoving everything else to the right. If it changes the width, returns T so that caller knows whether to update display") (LET ((OVERFLOW (|fetch| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER)) (CURRENTSTART (|fetch| (FILEBROWSER INFOSTART) |of| BROWSER)) THRESHOLD) (COND (OVERFLOW (* \; "See if enough files were too wide for print spec") (SETQ THRESHOLD (IMIN (IMAX (FIXR (FTIMES (|fetch| (FILEBROWSER TOTALFILES) |of| BROWSER) FB.OVERFLOW.MAXFRAC)) 1) FB.OVERFLOW.MAXABSOLUTE)) (|for| PAIR |in| OVERFLOW |when| (AND (IGREATERP (CAR PAIR) CURRENTSTART) (LESSP (SETQ THRESHOLD (IDIFFERENCE THRESHOLD (CADR PAIR))) 0)) |do| (* \; "Stop here! Any further than this and we would have more than the max files overflowing") (|replace| (FILEBROWSER INFOSTART) |of| BROWSER |with| (CAR PAIR)) (RETURN T)))))) -) (FB.SET.DEFAULT.NAME.WIDTH -(LAMBDA (BROWSER) (* |bvm:| "18-Oct-85 17:54") (LET ((FONT (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER))) (|replace| (FILEBROWSER INFOSTART) |of| BROWSER |with| (IPLUS (|replace| (FILEBROWSER NAMEOVERHEAD) |of| BROWSER |with| (IPLUS (DSPLEFTMARGIN NIL (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (CHARWIDTH (CHARCODE SPACE) FONT) (CHARWIDTH (CHARCODE \;) FONT))) FB.DEFAULT.NAME.WIDTH)) (|replace| (FILEBROWSER DIGITWIDTH) |of| BROWSER |with| (CHARWIDTH (CHARCODE 8) FONT)) (|replace| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER |with| NIL))) -) (FB.CREATE.FILEBUCKET -(LAMBDA (BROWSER FILENAME FILEINFO LASTFILEDATA) (* \; "Edited 1-Feb-88 14:44 by bvm:") (* |;;| "Create a FBFILEDATA encapsulating FILENAME and its FILEINFO. If LASTFILEDATA is supplied, it is the filedata from the previous file parsed, which we make use of to create canonical VERSIONLESSNAME fields.") (|if| (NOT (STRINGP FILENAME)) |then| (* \; "Some things are nicer if we force everything to be a string.") (SETQ FILENAME (STRING FILENAME))) (COND ((NULL (|fetch| (FILEBROWSER PATTERNPARSED?) |of| BROWSER)) (FB.ANALYZE.PATTERN BROWSER FILENAME))) (LET ((STARTOFNAME (|fetch| (FILEBROWSER NAMESTART) |of| BROWSER)) (NAMELENGTH (NCHARS FILENAME)) (VERSION 0) (DEPTH 0) STARTOFSHORTNAME LASTDIR PREVDIR LASTNAMECHAR HASDIRPREFIX DIRP ATTR TEM NEWFILEDATA) (SETQ LASTNAMECHAR NAMELENGTH) (|bind| (DEC _ 1) CH |while| (DIGITCHARP (SETQ CH (NTHCHARCODE FILENAME LASTNAMECHAR))) |do| (|add| VERSION (TIMES (- CH (CHARCODE 0)) DEC)) (SETQ DEC (TIMES 10 DEC)) (SETQ LASTNAMECHAR (SUB1 LASTNAMECHAR)) |finally| (* \; "not a version char") (COND ((EQ CH (CHARCODE \;)) (* \; "Pull off the version from the end, so that we can sort with it, etc. Note that we assume that all devices have converted native syntax to Lisp here.") (SETQ LASTNAMECHAR (SUB1 LASTNAMECHAR))) (T (SETQ VERSION 0) (* \; "Null version") (SETQ LASTNAMECHAR NIL)))) (SETQ NEWFILEDATA (|if| (AND LASTFILEDATA (STRING-EQUAL (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| LASTFILEDATA) FILENAME :END2 (OR LASTNAMECHAR NAMELENGTH))) |then| (* \; "This file is just like the previous one, except for attributes, full name and version") (|create| FBFILEDATA |using| LASTFILEDATA) |else| (|for| (N _ STARTOFNAME) |do| (SELCHARQ (NTHCHARCODE FILENAME (|add| N 1)) ((> /) (SETQ PREVDIR LASTDIR) (SETQ LASTDIR N) (|add| DEPTH 1)) (\' (* \; "Next char is quoted") (|add| N 1)) (NIL (RETURN)) NIL)) (|if| (EQ LASTDIR NAMELENGTH) |then| (* \; "It's a directory name (e.g., with ns), so make the name be the last subdirectory") (SETQ LASTDIR PREVDIR) (SETQ DIRP T) (|add| DEPTH -1)) (COND (LASTDIR (* \; "We found a directory delimiter following the common directory prefix of the pattern. ") (SETQ HASDIRPREFIX T) (SETQ STARTOFSHORTNAME (ADD1 LASTDIR)) (* \; "Directoryless name starts here") (COND ((NOT (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER)) (* \; "Use short name if allowed.") (SETQ STARTOFNAME STARTOFSHORTNAME)))) (T (SETQ STARTOFSHORTNAME STARTOFNAME))) (* \; "Note optimization: SUBDIREND is zero (SUBDIRECTORY null) when HASDIRPREFIX is NIL.") (|create| FBFILEDATA STARTOFPNAME _ STARTOFNAME VERSIONLESSNAME _ (COND (LASTNAMECHAR (SUBSTRING FILENAME 1 LASTNAMECHAR)) (T FILENAME)) SUBDIREND _ (OR LASTDIR 0) STARTOFNAME _ STARTOFSHORTNAME HASDIRPREFIX _ HASDIRPREFIX DIRECTORYFILEP _ DIRP FILEDEPTH _ DEPTH))) (|replace| (FBFILEDATA FILENAME) |of| NEWFILEDATA |with| FILENAME) (|replace| (FBFILEDATA VERSION) |of| NEWFILEDATA |with| VERSION) (|replace| (FBFILEDATA FILEINFO) |of| NEWFILEDATA |with| FILEINFO) (|replace| (FBFILEDATA SIZE) |of| NEWFILEDATA |with| (AND (SETQ ATTR (|fetch| (FILEBROWSER PAGECOUNT?) |of| BROWSER)) (SETQ TEM (CL:NTH (|fetch| (FILEBROWSER SIZEINDEX) |of| BROWSER) FILEINFO)) (SELECTQ ATTR (LENGTH (FOLDHI TEM BYTESPERPAGE)) TEM))) (FB.CHECK.NAME.LENGTH BROWSER NEWFILEDATA) (COND ((SETQ ATTR (|fetch| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER)) (SETQ ATTR (CL:NTH (|fetch| (FILEBROWSER SORTINDEX) |of| BROWSER) FILEINFO)) (COND ((AND ATTR (|fetch| (FILEBROWSER SORTBYDATE) |of| BROWSER)) (SETQ ATTR (IDATE ATTR)))) (|replace| (FBFILEDATA SORTVALUE) |of| NEWFILEDATA |with| ATTR))) NEWFILEDATA)) -) (FB.CHECK.NAME.LENGTH -(LAMBDA (BROWSER FILEDATA) (* \; "Edited 25-Jan-88 15:44 by bvm") (* |;;;| "Checks the name in FILEDATA to see if printing it would overflow the space set aside for the name column in the browser. If so, updates some information that will help us decide later whether to expand the column") (LET ((PRINTLENGTH (+ (STRINGWIDTH (|fetch| (FBFILEDATA PRINTNAME) |of| FILEDATA) (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER)) (|fetch| (FILEBROWSER NAMEOVERHEAD) |of| BROWSER)))) (COND ((>= PRINTLENGTH (|fetch| (FILEBROWSER INFOSTART) |of| BROWSER)) (* |;;| "Name is longer than allotted space in browser. Shall we allot more space? Don't know until we're thru. For now, record a list of elements (width occurrences), where each name is recorded in the closest entry") (LET ((OVERFLOW (|fetch| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER)) (SPACING (|fetch| (FILEBROWSER OVERFLOWSPACING) |of| BROWSER))) (COND ((OR (NULL OVERFLOW) (> PRINTLENGTH (CAAR OVERFLOW))) (|replace| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER |with| (CONS (LIST PRINTLENGTH 1) OVERFLOW))) (T (|for| (TAIL _ OVERFLOW) |bind| PREVTAIL |when| (OR (NULL (SETQ TAIL (CDR (SETQ PREVTAIL TAIL)))) (> PRINTLENGTH (CAR (CAR TAIL)))) |do| (* \; "Longer than some previously recorded length, so either add a new entry or bump the preceding one") (COND ((< PRINTLENGTH (- (CAR (CAR PREVTAIL)) SPACING)) (RPLACD PREVTAIL (CONS (LIST PRINTLENGTH 1) TAIL))) (T (|add| (CADR (CAR PREVTAIL)) 1))) (RETURN))))))))) -) (FB.ADD.FILEGROUP -(LAMBDA (TBROWSER FBROWSER FIRSTDATA OTHERDATA PREVDATA) (* \; "Edited 1-Feb-88 14:43 by bvm:") (* |;;| "Appends to FBROWSER the set of files FIRSTDATA plus each of OTHERDATA, all of which are known to have the same name save version number. PREVDATA is representative of the last item we inserted.") (COND ((AND (NOT (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| FBROWSER)) (NOT (|if| PREVDATA |then| (EQ.DIRECTORYP PREVDATA FIRSTDATA) |else| (NULL.DIRECTORYP FIRSTDATA)))) (* \; "The new files have a different subdirectory, so insert a non-selectable line item here") (FB.INSERT.DIRECTORY TBROWSER FBROWSER FIRSTDATA))) (COND (OTHERDATA (* \; "More than one file to add, so sort versions") (|for| ITEM |in| (SORT (|for| D |in| (CONS FIRSTDATA OTHERDATA) |collect| (|create| TABLEITEM TIDATA _ D)) (FUNCTION FB.DECREASING.VERSION)) |do| (FB.ADD.FILE TBROWSER FBROWSER ITEM))) (T (FB.ADD.FILE TBROWSER FBROWSER (|create| TABLEITEM TIDATA _ FIRSTDATA))))) -) (FB.INSERT.DIRECTORY -(LAMBDA (TBROWSER FBROWSER DATAWITHSUBDIR BEFOREITEM) (* \; "Edited 25-Jan-88 17:13 by bvm") (TB.INSERT.ITEM TBROWSER (FB.MAKE.SUBDIRECTORY.ITEM FBROWSER DATAWITHSUBDIR) BEFOREITEM)) -) (FB.MAKE.SUBDIRECTORY.ITEM -(LAMBDA (FBROWSER DATAWITHSUBDIR) (* \; "Edited 26-Jan-88 10:58 by bvm") (* |;;;| "Creates a TABLEITEM containing a subdirectory line identifying the subdirectory in DATAWITHSUBDIR. If item has no subdirectory, we use the browser's pattern directory") (LET* ((SUBDIRECTORY (OR (|fetch| (FBFILEDATA SUBDIRECTORY) |of| DATAWITHSUBDIR) (SUBSTRING (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) 1 (SUB1 (|fetch| (FILEBROWSER NAMESTART) |of| FBROWSER))))) (DIRSTART (|fetch| (FILEBROWSER DIRECTORYSTART) |of| FBROWSER))) (|create| TABLEITEM TIUNSELECTABLE _ T TIDATA _ (|create| FBFILEDATA FILENAME _ SUBDIRECTORY STARTOFPNAME _ (|if| (<= DIRSTART (NCHARS SUBDIRECTORY)) |then| DIRSTART |else| (* \; "No directory--use whole name") 1) VERSIONLESSNAME _ SUBDIRECTORY DIRECTORYP _ T)))) -) (FB.ADD.FILE -(LAMBDA (TBROWSER FBROWSER ITEM BEFOREITEM) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Inserts one file in TBROWSER / FBROWSER before item BEFOREITEM or at end if BEFOREITEM is NIL") (LET ((SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM)))) (COND (SIZE (|add| (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) SIZE))) (|add| (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER) 1) (TB.INSERT.ITEM TBROWSER ITEM BEFOREITEM))) -) (FB.INSERT.FILE -(LAMBDA (BROWSER FILE) (* \; "Edited 25-Jan-88 18:31 by bvm") (LET ((TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (FBSORTFN (|fetch| (FILEBROWSER SORTBY) |of| BROWSER)) (MYDATA (|fetch| TIDATA |of| FILE)) (NOSUBDIRS (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER)) OTHERDATA NEXTITEM PREVITEM N) (SETQ NEXTITEM (TB.FIND.ITEM TBROWSER (FUNCTION (LAMBDA (BROWSER ITEM) (AND (NOT (|fetch| TIUNSELECTABLE |of| ITEM)) (CL:FUNCALL FBSORTFN FILE ITEM)))))) (COND ((AND NEXTITEM (NOT NOSUBDIRS) (NEQ (SETQ N (|fetch| TI# |of| NEXTITEM)) 1) (|fetch| TIUNSELECTABLE |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))) (NOT (EQ.DIRECTORYP MYDATA (|fetch| TIDATA |of| NEXTITEM)))) (* |;;| "We sort before NEXTITEM, but it's preceded by a subdirectory line that isn't ours, so insert in front of the subdirectory") (SETQ NEXTITEM PREVITEM))) (TB.INSERT.ITEM TBROWSER FILE NEXTITEM) (COND (NOSUBDIRS) ((AND NEXTITEM (NOT (|fetch| TIUNSELECTABLE |of| NEXTITEM)) (EQ.DIRECTORYP MYDATA (SETQ OTHERDATA (|fetch| TIDATA |of| NEXTITEM)))) (* |;;| "All ok -- next item is not a subdirectory line, and its subdir is the same as mine, so I must be properly qualified already")) (T (* |;;| "Inserted at end, or newly inserted item has different subdirectory from the item that follows it") (COND ((AND NEXTITEM (NOT (|fetch| TIUNSELECTABLE |of| NEXTITEM))) (* \; "Need subdirectory id in front of next file") (FB.INSERT.DIRECTORY TBROWSER BROWSER OTHERDATA NEXTITEM))) (COND ((COND ((EQ (SETQ N (|fetch| TI# |of| FILE)) 1) (* \; "Inserted at front, needs qualification if it has a subdir") (NOT (NULL.DIRECTORYP MYDATA))) (T (NOT (EQ.DIRECTORYP MYDATA (|fetch| TIDATA |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))))))) (* \; "Need id in front of new file as well") (FB.INSERT.DIRECTORY TBROWSER BROWSER MYDATA FILE))))) (FB.COUNT.FILE.CHANGE BROWSER FILE (QUOTE ADD)))) -) (FB.ANALYZE.PATTERN -(LAMBDA (BROWSER SAMPLE) (* \; "Edited 6-Apr-90 20:00 by NM") (* |;;;| "Figures out what the 'real pattern' is from SAMPLE, one of the files that is claimed to match the pattern. Sets the NAMESTART field to where the pattern ends and the distinguishable names start. Also resets PATTERN to be the canonicalized pattern") (PROG ((PATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER)) (SAMPLEHOSTEND 0) PATHOSTEND LASTPATDIR STARTOFNAME) (|do| (* \; "Find end of sample's host name") (SELCHARQ (NTHCHARCODE SAMPLE (|add| SAMPLEHOSTEND 1)) (\' (|add| SAMPLEHOSTEND 1)) (} (* \; "End of directory") (RETURN)) (NIL (* \; "End of file name without end of brace?") (RETURN (SETQ SAMPLEHOSTEND 0))) NIL)) RETRY (SETQ PATHOSTEND 0) (|do| (SELCHARQ (NTHCHARCODE PATTERN (|add| PATHOSTEND 1)) (\' (|add| PATHOSTEND 1)) (} (* \; "End of directory, now look for end of matchable pattern") (RETURN (|for| (N _ PATHOSTEND) |do| (SELCHARQ (NTHCHARCODE PATTERN (|add| N 1)) (\' (|add| N 1)) ((\: < > /) (* \; "{DSK} and {UNIX} on Sun represent root directory in a form of \"{DSK}, or {x/n}<~> might become {x/n}jones>.") (OR (SELCHARQ (NTHCHARCODE SAMPLE (|add| SAMPLEHOSTEND 1)) ((< /) (* \; "Good, there's a directory -- canonicalize it") (LET ((CANONICAL (DIRECTORYNAME (SUBSTRING PATTERN 1 (OR LASTPATDIR (SETQ LASTPATDIR PATHOSTEND)))))) (AND CANONICAL (CONCAT CANONICAL (SUBSTRING PATTERN (ADD1 LASTPATDIR)))))) (PROGN (* \; "File coming back has no directory, so there's nothing interesting to do") NIL)) PATTERN)) -) (FB.GETALLFILEINFO -(LAMBDA (BROWSER GENERATOR ATTRIBUTES) (* \; "Edited 1-Feb-88 15:50 by bvm:") (* |;;| "Returns a FILEINFO field for the given attribute specs") (|for| ATTR |in| ATTRIBUTES |bind| VALUE TREESIZE |collect| (SETQ VALUE (\\GENERATEFILEINFO GENERATOR (CAR ATTR))) (|if| (AND (EQ VALUE 0) (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER) (FMEMB (CAR ATTR) (QUOTE (SIZE LENGTH))) (SETQ TREESIZE (\\GENERATEFILEINFO GENERATOR (QUOTE SUBTREE.SIZE)))) |then| (* |;;| "This is an NS directory node, so get its subtree size, which is much more interesting than size, which is always zero (directories have no data)") (SELECTQ (CAR ATTR) (SIZE (FOLDHI TREESIZE BYTESPERPAGE)) (LENGTH TREESIZE) (SHOULDNT)) |else| VALUE))) -) ) (DEFINEQ (FB.SORT.VERSIONS -(LAMBDA (ITEMS SORTFN) (* \; "Edited 25-Jan-88 15:22 by bvm") (* |;;;| "Sort ITEMS so that equal names are sorted by version according to SORTFN. Assumes that ITEMS are already sorted by name") (LET ((TAIL ITEMS) PREVTAIL NEXTTAIL NEWTAIL THISNAME) (|while| (CDR TAIL) |do| (COND ((STRING-EQUAL (SETQ THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| (CAR TAIL)))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| (CADR TAIL)))) (* \; "Same name as next, so gather up all equal names") (SETQ NEXTTAIL (CDDR TAIL)) (|while| (AND NEXTTAIL (STRING-EQUAL THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| (CAR NEXTTAIL))))) |do| (SETQ NEXTTAIL (CDR NEXTTAIL))) (SETQ NEWTAIL (SORT (|until| (EQ TAIL NEXTTAIL) |collect| (|pop| TAIL)) SORTFN)) (* \; "Now splice NEWTAIL into list between PREVTAIL and NEXTTAIL") (COND (PREVTAIL (RPLACD PREVTAIL NEWTAIL)) (T (SETQ ITEMS NEWTAIL))) (COND ((SETQ TAIL NEXTTAIL) (RPLACD (SETQ PREVTAIL (LAST NEWTAIL)) NEXTTAIL)))) (T (SETQ TAIL (CDR (SETQ PREVTAIL TAIL)))))) ITEMS)) -) (FB.DECREASING.VERSION -(LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:53") (* |;;;| "Comparefn for sorting a group of same named files by decreasing version. Null version considered high") (AND (NOT (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| Y))))) (OR (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| X)))) (IGREATERP X Y)))) -) (FB.INCREASING.VERSION -(LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:55") (* |;;;| "Comparefn for sorting a group of same named files by increasing version. Null version considered high") (OR (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| Y)))) (AND (NOT (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| X))))) (ILESSP X Y)))) -) (FB.NAMES.DECREASING.VERSION -(LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:57") (* |;;;| "Comparison function for sorting file names in alphabetical order, decreasing versions") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ X (|fetch| TIDATA |of| X))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ Y (|fetch| TIDATA |of| Y))) UPPERCASEARRAY) (LESSP T) (EQUAL (AND (NOT (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| Y)) 0)) (OR (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| X))) (IGREATERP X Y)))) NIL)) -) (FB.NAMES.INCREASING.VERSION -(LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:54") (* |;;;| "Comparison function for sorting file names in alphabetical order, increasing versions") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ X (|fetch| TIDATA |of| X))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ Y (|fetch| TIDATA |of| Y))) UPPERCASEARRAY) (LESSP T) (EQUAL (OR (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| Y))) (AND (NOT (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| X)))) (ILESSP X Y)))) NIL)) -) (FB.DECREASING.NUMERIC.ATTR -(LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Comparison function for sorting file names in decreasing order of some numeric attribute. If values are equal, fall back on names decreasing version") (LET ((XVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) 0)) (YVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) 0))) (OR (IGREATERP XVAL YVAL) (AND (NOT (IGREATERP YVAL XVAL)) (FB.NAMES.DECREASING.VERSION X Y))))) -) (FB.INCREASING.NUMERIC.ATTR -(LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Comparison function for sorting file names in increasing order of some numeric attribute. If values are equal, fall back on names decreasing version") (LET ((XVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) 0)) (YVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) 0))) (OR (ILESSP XVAL YVAL) (AND (NOT (ILESSP YVAL XVAL)) (FB.NAMES.DECREASING.VERSION X Y))))) -) (FB.ALPHABETIC.ATTR -(LAMBDA (X Y) (* |bvm:| "20-Oct-85 18:07") (* |;;;| "Comparison function for sorting file names in order of some textual attribute. If values are equal, fall back on names decreasing version") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) UPPERCASEARRAY) (LESSP T) (EQUAL (FB.NAMES.DECREASING.VERSION X Y)) NIL)) -) ) (DEFINEQ (FB.SORTCOMMAND -(LAMBDA (BROWSER) (* \; "Edited 29-Jan-88 12:47 by bvm") (PROG ((TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (HADNOSUBDIRS (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER)) SORTATTR SORT# SORTFN REVERSED ALLFILES DATETYPE BYNAME) (COND ((NULL (SETQ SORTATTR (MENU (FB.GET.SORT.MENU BROWSER)))) (RETURN)) ((LISTP SORTATTR) (SETQ REVERSED T) (SETQ SORTATTR (CAR SORTATTR)))) (SETQ SORTFN (SELECTQ SORTATTR ((SIZE LENGTH BYTESIZE) (COND (REVERSED (FUNCTION FB.INCREASING.NUMERIC.ATTR)) (T (FUNCTION FB.DECREASING.NUMERIC.ATTR)))) ((CREATIONDATE WRITEDATE READDATE) (SETQ DATETYPE T) (COND (REVERSED (FUNCTION FB.INCREASING.NUMERIC.ATTR)) (T (FUNCTION FB.DECREASING.NUMERIC.ATTR)))) (NAME (SETQ BYNAME T) (COND (REVERSED (FUNCTION FB.NAMES.INCREASING.VERSION)) (T (FUNCTION FB.NAMES.DECREASING.VERSION)))) (FUNCTION FB.ALPHABETIC.ATTR))) (FB.PROMPTW.FORMAT BROWSER "Sorting by ~A..." SORTATTR) (SETQ ALLFILES (TB.COLLECT.ITEMS TBROWSER (FUNCTION FB.IS.NOT.SUBDIRECTORY.ITEM))) (COND ((NOT BYNAME) (* \; "Need to compute the attribute on which we sort") (SETQ SORT# (OR (CL:POSITION SORTATTR (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER) :KEY (FUNCTION CAR)) (HELP "Couldn't find sort attribute" SORTATTR))) (|for| ITEM |in| ALLFILES |bind| (NAMESTART _ (AND (NOT HADNOSUBDIRS) (|fetch| (FILEBROWSER NAMESTART) |of| BROWSER))) DATA VALUE |do| (SETQ DATA (|fetch| TIDATA |of| ITEM)) (SETQ VALUE (CL:NTH SORT# (|fetch| (FBFILEDATA FILEINFO) |of| DATA))) (COND ((AND VALUE DATETYPE) (SETQ VALUE (IDATE VALUE)))) (|replace| (FBFILEDATA SORTVALUE) |of| DATA |with| VALUE) (COND ((AND NAMESTART (|fetch| (FBFILEDATA HASDIRPREFIX) |of| DATA)) (* \; "Need to go back to 'full' names, since subdirectories are senseless when not sorted by name") (|replace| (FBFILEDATA STARTOFPNAME) |of| DATA |with| NAMESTART) (FB.CHECK.NAME.LENGTH BROWSER DATA))))) (HADNOSUBDIRS (* \; "We're sorting by name, so switch back to print names without subdirs") (FB.SET.DEFAULT.NAME.WIDTH BROWSER) (|for| DATA |in| ALLFILES |do| (COND ((|fetch| (FBFILEDATA HASDIRPREFIX) |of| (SETQ DATA (|fetch| TIDATA |of| DATA))) (|replace| (FBFILEDATA STARTOFPNAME) |of| DATA |with| (|fetch| (FBFILEDATA STARTOFNAME) |of| DATA)))) (FB.CHECK.NAME.LENGTH BROWSER DATA)))) (SETQ ALLFILES (SORT ALLFILES SORTFN)) (COND ((EQ BYNAME HADNOSUBDIRS) (* \; "Were wide names, now narrow, or vice versa") (FB.MAYBE.WIDEN.NAMES BROWSER))) (COND (BYNAME (FB.INSERT.SUBDIRECTORIES BROWSER ALLFILES))) (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (TB.REPLACE.ITEMS TBROWSER ALLFILES) (|replace| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER |with| (NOT BYNAME)) (|replace| (FILEBROWSER SORTBY) |of| BROWSER |with| SORTFN) (|replace| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER |with| (AND (NOT BYNAME) SORTATTR)) (|if| SORT# |then| (|replace| (FILEBROWSER SORTINDEX) |of| BROWSER |with| SORT#)) (|replace| (FILEBROWSER SORTBYDATE) |of| BROWSER |with| DATETYPE) (FB.PROMPTWPRINT BROWSER "done"))) -) (FB.INSERT.SUBDIRECTORIES -(LAMBDA (BROWSER FILES) (* \; "Edited 26-Jan-88 10:45 by bvm") (|for| TAIL |on| FILES |bind| (LASTDATA _ (|create| FBFILEDATA SUBDIREND _ 0)) |when| (NOT (EQ.DIRECTORYP LASTDATA (SETQ LASTDATA (|fetch| TIDATA |of| (CAR TAIL))))) |do| (* \; "This guy's directory differs from previous, so add subdirectory item") (ATTACH (FB.MAKE.SUBDIRECTORY.ITEM BROWSER LASTDATA) TAIL) (SETQ TAIL (CDR TAIL)))) -) (FB.GET.SORT.MENU -(LAMBDA (BROWSER) (* \; "Edited 26-Jan-88 12:38 by bvm") (OR (|fetch| (FILEBROWSER SORTMENU) |of| BROWSER) (|replace| (FILEBROWSER SORTMENU) |of| BROWSER |with| (|create| MENU ITEMS _ (CONS (QUOTE ("Name" (QUOTE NAME) "Sort files by name, decreasing version numbers" (SUBITEMS ("Decreasing version" (QUOTE NAME) "Sort files by name, decreasing version numbers") ("Increasing version" (QUOTE (NAME T)) "Sort files by name, increasing version numbers")))) (|for| ATTR |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER) |collect| (BQUOTE ((\\\, (SETQ ATTR (CAR ATTR))) (QUOTE (\\\, ATTR)) "Sort by this attribute" (\\\, (SELECTQ ATTR ((SIZE LENGTH BYTESIZE) (BQUOTE (SUBITEMS ("Decreasing" (QUOTE (\\\, ATTR)) "Sort files in order of decreasing size") ("Increasing" (QUOTE ((\\\, ATTR) T)) "Sort files in order of increasing size")))) ((CREATIONDATE WRITEDATE READDATE) (BQUOTE (SUBITEMS ("Newer first" (QUOTE (\\\, ATTR)) "Sort files with newer dates appearing before older dates") ("Older first" (QUOTE ((\\\, ATTR) T)) "Sort files with older dates appearing before newer dates")))) NIL)))))))))) -) ) (DEFINEQ (FB.EXPUNGECOMMAND -(LAMBDA (FBROWSER KEY ITEM MENU CMD) (* \; "Edited 9-Apr-93 22:07 by jds") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER)) (NDELETED 0) FILES FILENAME FAILED FILE) (COND ((SETQ FILES (TB.COLLECT.ITEMS TBROWSER (QUOTE DELETED))) (FB.PROMPTWPRINT FBROWSER T "Expunging deleted files...") (FB.ALLOW.ABORT FBROWSER) (|for| ITEM |in| FILES |do| (COND ((DELFILE (SETQ FILENAME (FB.FETCHFILENAME ITEM))) (|add| NDELETED 1) (FB.REMOVE.FILE TBROWSER FBROWSER ITEM) (FB.UPDATE.COUNTERS FBROWSER (QUOTE BOTH))) (T (FB.PROMPTWPRINT FBROWSER T "Couldn't expunge " FILENAME) (SETQ FAILED T))) (* |;;| "Let other things run (Like the mouse, so user can ABORT the expunge!)") (BLOCK)) (FB.PROMPTWPRINT FBROWSER (COND ((EQ NDELETED 0) " -No") (T (CONCAT (COND (FAILED " -Done, but only ") (T "done, ")) NDELETED))) " files expunged.") (COND (FAILED (COND (CMD (FB.PROMPTW.FORMAT FBROWSER " ~A aborted." CMD))) (RETURN NIL)))) (T (FB.PROMPTWPRINT FBROWSER T "No files were marked for deletion"))) (RETURN T))) -) (FB.NEWPATTERNCOMMAND -(LAMBDA (BROWSER) (* \; "Edited 28-Jan-88 01:11 by bvm") (LET (PATTERN) (COND ((AND (FB.MAYBE.EXPUNGE BROWSER "New Pattern") (SETQ PATTERN (FB.GET.NEWPATTERN BROWSER))) (FB.SETNEWPATTERN BROWSER PATTERN) (FB.UPDATEBROWSERITEMS BROWSER))))) -) (FB.NEWINFOCOMMAND -(LAMBDA (BROWSER) (* \; "Edited 30-Aug-94 19:47 by jds") (LET ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (INFOMENUW (|fetch| (FILEBROWSER INFOMENUW) |of| BROWSER)) REG) (COND ((NOT (OPENWP INFOMENUW)) (SETQ INFOMENUW (MENUWINDOW (|create| MENU ITEMS _ FB.INFO.MENU.ITEMS MENUROWS _ 2 TITLE _ "Info Options" CENTERFLG _ T MENUFONT _ FB.MENUFONT WHENSELECTEDFN _ (FUNCTION FB.INFOMENU.WHENSELECTEDFN)))) (ATTACHWINDOW INFOMENUW WINDOW (QUOTE BOTTOM) (QUOTE JUSTIFY) (QUOTE LOCALCLOSE)) (COND ((LESSP (|fetch| (REGION BOTTOM) |of| (SETQ REG (WINDOWPROP INFOMENUW (QUOTE REGION)))) 0) (* \; "Bump whole window up on screen so we can see it") (MOVEW WINDOW (|create| POSITION XCOORD _ (|fetch| (REGION LEFT) |of| REG) YCOORD _ (|fetch| (REGION HEIGHT) |of| REG))))) (FB.INFOMENU.SHADEINITIALSELECTIONS INFOMENUW (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER)) (|replace| (FILEBROWSER INFOMENUW) |of| BROWSER |with| INFOMENUW) (WINDOWADDPROP INFOMENUW (QUOTE CLOSEFN) (FUNCTION (LAMBDA (W) (AND (SETQ W (WINDOWPROP (MAINWINDOW W T) (QUOTE FILEBROWSER))) (|replace| (FILEBROWSER INFOMENUW) |of| W |with| NIL)))) T))) (FB.PROMPTWPRINT BROWSER (QUOTE CLEAR) "Select from the lower menu which attributes are to be displayed, -then click Recompute")))) (FB.DEPTHCOMMAND -(LAMBDA (FBROWSER) (* \; "Edited 1-Feb-88 13:54 by bvm:") (LET ((OLDDEPTH (|fetch| (FILEBROWSER FBDEPTH) |of| FBROWSER)) NEWDEPTH) (FB.PROMPTWPRINT FBROWSER "Current depth is " (SELECTQ OLDDEPTH (NIL "global default") (T "infinite") OLDDEPTH) T "Specify new depth") (|if| (EQ (SETQ NEWDEPTH (MENU (|create| MENU ITEMS _ FB.DEPTH.MENU.ITEMS CENTERFLG _ T))) :NUMBER) |then| (FB.ALLOW.ABORT FBROWSER) (SETQ NEWDEPTH (RNUMBER "Enumeration Depth" NIL NIL NIL T NIL T))) (|if| (NULL NEWDEPTH) |then| (FB.PROMPTWPRINT FBROWSER T "Depth unchanged") |else| (FB.PROMPTWPRINT FBROWSER T "Depth set to " (SELECTQ NEWDEPTH (:GLOBAL (SETQ NEWDEPTH NIL) "global default") (T "infinity") NEWDEPTH) " for future Recomputes") (|replace| (FILEBROWSER FBDEPTH) |of| FBROWSER |with| NEWDEPTH)))) -) (FB.SHAPECOMMAND -(LAMBDA (BROWSER) (* \; "Edited 2-Feb-88 12:02 by bvm:") (* |;;| "Widen or narrow the browser so that all information is visible") (LET* ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (WREG (WINDOWREGION WINDOW)) (WWIDTH (|fetch| (REGION WIDTH) |of| WREG)) (EXTENT (WINDOWPROP WINDOW (QUOTE EXTENT))) EXCESSHEIGHT MENUW) (* |;;| "Add enough to the whole region width to compensate for the excess of the extent over the actual width, but don't get wider than the screen less a scroll bar. Using the EXTENT is not entirely correct--EXTENT's width reflects the widest line we have attempted to print, not the widest line we MIGHT print if window were scrolled to other items.") (|replace| (REGION WIDTH) |of| WREG |with| (SETQ WWIDTH (MIN (+ WWIDTH (- (|fetch| (REGION WIDTH) |of| EXTENT) (WINDOWPROP WINDOW (QUOTE WIDTH)))) (- SCREENWIDTH SCROLLBARWIDTH)))) (|if| (AND (> (SETQ EXCESSHEIGHT (- (WINDOWPROP WINDOW (QUOTE HEIGHT)) (|fetch| (REGION HEIGHT) |of| EXTENT))) 0) (SETQ MENUW (CDR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER)))) |then| (* \; "Window is also taller than it needs to be--shrink it back, though not smaller than the minimum height") (|replace| (REGION HEIGHT) |of| WREG |with| (MAX (- (|fetch| (REGION HEIGHT) |of| WREG) EXCESSHEIGHT) (+ (|fetch| (REGION HEIGHT) |of| (WINDOWPROP MENUW (QUOTE REGION))) (|fetch| (REGION HEIGHT) |of| (WINDOWPROP (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER) (QUOTE REGION)))))) |else| (SETQ EXCESSHEIGHT NIL)) (|if| (> (|fetch| (REGION PRIGHT) |of| WREG) SCREENWIDTH) |then| (* \; "If we're sticking over the edge on the right, move the region leftward.") (|replace| (REGION LEFT) |of| WREG |with| (- SCREENWIDTH WWIDTH))) (RESHAPEALLWINDOWS WINDOW WREG) (|if| EXCESSHEIGHT |then| (* \; "Silly reshaping routine tried to preserve the bottom, so scrolled the window up. Let's scroll it back down.") (SCROLLW WINDOW 0 (- EXCESSHEIGHT))))) -) (FB.REMOVE.FILE -(LAMBDA (TBROWSER FBROWSER ITEM) (* \; "Edited 25-Jan-88 17:24 by bvm") (* |;;;| "Removes ITEM from browser display, counts its removal") (LET ((N (|fetch| TI# |of| ITEM)) PREVITEM NEXTITEM NEXTNEXTITEM) (COND ((AND (NEQ N 1) (|fetch| TIUNSELECTABLE |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))) (OR (NULL (SETQ NEXTITEM (TB.NTH.ITEM TBROWSER (ADD1 N)))) (|fetch| TIUNSELECTABLE |of| NEXTITEM))) (* \; "ITEM is between two subdirectory lines, so remove at least the preceding line") (TB.REMOVE.ITEM TBROWSER PREVITEM) (COND ((AND NEXTITEM (SETQ NEXTNEXTITEM (TB.NTH.ITEM TBROWSER (ADD1 N))) (COND ((EQ (|add| N -1) 1) (* |;;| "N decremented because of the remove above. Now removing first file, so see if next file has no subdir") (NULL.DIRECTORYP (|fetch| TIDATA |of| NEXTNEXTITEM))) (T (EQ.DIRECTORYP (|fetch| TIDATA |of| NEXTNEXTITEM) (|fetch| TIDATA |of| (TB.NTH.ITEM TBROWSER (SUB1 N))))))) (* |;;| "The next subdirectory line is superfluous, because the file after it and the file before us have the same subdirectory") (TB.REMOVE.ITEM TBROWSER NEXTITEM))))) (TB.REMOVE.ITEM TBROWSER ITEM) (FB.COUNT.FILE.CHANGE FBROWSER ITEM (QUOTE REMOVE)))) -) (FB.COUNT.FILE.CHANGE -(LAMBDA (FBROWSER ITEM FLG) (* |bvm:| "13-Oct-85 17:47") (* |;;;| "Account for the addition or removal of ITEM from FBROWSER -- FLG is ADD or REMOVE") (LET ((SIGN (SELECTQ FLG (ADD 1) (REMOVE -1) (SHOULDNT))) (SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (DELETEDP (|fetch| TIDELETED |of| ITEM))) (|replace| (FILEBROWSER TOTALFILES) |of| FBROWSER |with| (|add| (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER) SIGN)) (COND (DELETEDP (|replace| (FILEBROWSER DELETEDFILES) |of| FBROWSER |with| (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) SIGN)))) (COND (SIZE (|add| (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) (SETQ SIZE (ITIMES SIZE SIGN))) (COND (DELETEDP (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) SIZE))))))) -) (FB.SETNEWPATTERN -(LAMBDA (FBROWSER PATTERN) (* \; "Edited 1-Feb-88 15:46 by bvm:") (* |;;| "Called to install a new PATTERN in a filebrowser. PATTERN should already have been passed thru DIRECTORY.FILL.PATTERN.") (LET (ICON) (|replace| (FILEBROWSER PATTERN) |of| FBROWSER |with| PATTERN) (|replace| (FILEBROWSER PREPAREDPATTERN) |of| FBROWSER |with| (DIRECTORY.MATCH.SETUP PATTERN)) (|replace| (FILEBROWSER PATTERNPARSED?) |of| FBROWSER |with| NIL) (|replace| (FILEBROWSER NSPATTERN?) |of| FBROWSER |with| (STRPOS ":" (UNPACKFILENAME.STRING PATTERN (QUOTE HOST)))) (COND ((SETQ ICON (WINDOWPROP (|fetch| (FILEBROWSER BROWSERWINDOW) |of| FBROWSER) (QUOTE ICONWINDOW))) (* \; "Change the icon label") (ICONW.TITLE ICON PATTERN))) PATTERN)) -) (FB.GET.NEWPATTERN -(LAMBDA (BROWSER) (* \; "Edited 30-Aug-94 19:47 by jds") (FB.ALLOW.ABORT BROWSER) (LET* ((OLDPATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER)) (PATTERN (FB.PROMPTFORINPUT (COND (OLDPATTERN "New file group description: ") (T "File group description: ")) OLDPATTERN BROWSER T))) (COND (PATTERN (DIRECTORY.FILL.PATTERN PATTERN))))) -) (FB.OPTIONSCOMMAND -(LAMBDA (BROWSER) (* |bvm:| "13-Sep-85 16:13") (FB.PROMPTWPRINT BROWSER "Please use the Options roll-out submenu to select the option you desire.")) -) ) (* \; "window functions") (DEFINEQ (FB.INFOMENU.SHADEINITIALSELECTIONS -(LAMBDA (MENUWINDOW INITIALSELECTIONS) (* \; "Edited 21-Jan-88 18:36 by bvm") (LET* ((MENU (CAR (WINDOWPROP MENUWINDOW (QUOTE MENU)))) (MENUITEMS (|fetch| (MENU ITEMS) |of| MENU))) (|for| SELECTION |in| INITIALSELECTIONS |do| (SHADEITEM (FB.INFO.ITEM.NAMED SELECTION MENUITEMS) MENU FB.INFOSHADE MENUWINDOW)))) -) (FB.INFO.ITEM.NAMED -(LAMBDA (TAG ITEMS) (* \; "Edited 21-Jan-88 17:38 by bvm") (* |;;;| "search list items for one with second element TAG") (|for| ITEM |in| ITEMS |when| (STRING-EQUAL (CADR ITEM) TAG) |do| (RETURN ITEM))) -) ) (DEFINEQ (FB.MAKECOUNTERWINDOW -(LAMBDA (BROWSERWINDOW FONT WIDTH HEIGHT TITLE) (* \; "Edited 30-Aug-94 19:47 by jds") (LET ((COUNTERW (CREATEW (|create| REGION LEFT _ 0 BOTTOM _ 0 HEIGHT _ HEIGHT WIDTH _ WIDTH) (OR TITLE "File Browser Window") NIL T))) (FB.MAKERIGIDWINDOW COUNTERW) (DSPFONT FONT COUNTERW) (ATTACHWINDOW COUNTERW BROWSERWINDOW (QUOTE TOP)) (|replace| (FILEBROWSER COUNTERWINDOW) |of| (WINDOWPROP BROWSERWINDOW (QUOTE FILEBROWSER)) |with| COUNTERW) (WINDOWPROP COUNTERW (QUOTE REPAINTFN) (FUNCTION FB.COUNTERW.REDISPLAYFN)) (WINDOWPROP COUNTERW (QUOTE RESHAPEFN) (FUNCTION FB.COUNTERW.REDISPLAYFN)) (WINDOWPROP COUNTERW (QUOTE PAGEFULLFN) (FUNCTION NILL)) COUNTERW)) -) (FB.COUNTERW.REDISPLAYFN -(LAMBDA (COUNTERWINDOW) (* \; "Edited 4-Feb-88 15:11 by bvm:") (LET ((BROWSER (WINDOWPROP (MAINWINDOW COUNTERWINDOW T) (QUOTE FILEBROWSER)))) (|if| (|fetch| (FILEBROWSER FBREADY) |of| BROWSER) |then| (* \; "Don't do this if user reshapes while we're still enumerating.") (CLEARW COUNTERWINDOW) (FB.DISPLAY.COUNTERS BROWSER)))) -) (FB.UPDATE.COUNTERS -(LAMBDA (FBROWSER TYPE) (* \; "Edited 30-Aug-94 19:48 by jds") (LET* ((COUNTERW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| FBROWSER)) (XPOSPAIRS (|fetch| (FILEBROWSER COUNTERPOSITIONS) |of| FBROWSER)) (TOTAL (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER)) (TOTALPAGES (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER)) (DEL (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER)) (DELPAGES (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER)) (PAGESTRING (|fetch| (FILEBROWSER COUNTERPAGESTRING) |of| FBROWSER)) (HEIGHT (WINDOWPROP COUNTERW (QUOTE HEIGHT))) HERE LABELS) (SETQ LABELS (LIST (COND ((|fetch| (FILEBROWSER SHOWUNDELETED?) |of| FBROWSER) (FB.COUNTER.STRING FBROWSER (IDIFFERENCE TOTAL DEL) (IDIFFERENCE TOTALPAGES DELPAGES))) ((NEQ TYPE (QUOTE DELETED)) (* \; "Don't need to update total if only deleted count changed") (FB.COUNTER.STRING FBROWSER TOTAL TOTALPAGES))) (AND (NEQ TYPE (QUOTE TOTAL)) (FB.COUNTER.STRING FBROWSER DEL DELPAGES)))) (DSPXPOSITION 0 COUNTERW) (|for| LAB |in| LABELS |as| PAIR |in| XPOSPAIRS |when| LAB |do| (DSPXPOSITION (CAR PAIR) COUNTERW) (PRIN3 LAB COUNTERW) (PRIN3 PAGESTRING COUNTERW) (BLTSHADE WHITESHADE COUNTERW (SETQ HERE (DSPXPOSITION NIL COUNTERW)) 0 (IDIFFERENCE (CADR PAIR) HERE) HEIGHT (QUOTE REPLACE))))) -) (FB.DISPLAY.COUNTERS -(LAMBDA (FBROWSER) (* \; "Edited 30-Aug-94 19:48 by jds") (LET* ((COUNTERW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| FBROWSER)) (TOTAL (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER)) (TOTALPAGES (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER)) (DEL (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER)) (DELPAGES (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER)) (COUNTERWIDTH (WINDOWPROP COUNTERW (QUOTE WIDTH))) (COUNTERFONT (DSPFONT NIL COUNTERW)) (SECTIONWIDTH (IQUOTIENT COUNTERWIDTH 2)) (THRESHOLDWIDTH (IDIFFERENCE SECTIONWIDTH (ITIMES 2 (CHARWIDTH (CHARCODE \a) COUNTERFONT)))) (HEIGHT (WINDOWPROP COUNTERW (QUOTE HEIGHT))) PAGESTRING MAXWIDTH HERE LABELS) (SETQ LABELS (LIST (COND ((|fetch| (FILEBROWSER SHOWUNDELETED?) |of| FBROWSER) (LIST "Undeleted: " (FB.COUNTER.STRING FBROWSER (IDIFFERENCE TOTAL DEL) (IDIFFERENCE TOTALPAGES DELPAGES)))) (T (LIST "Total: " (FB.COUNTER.STRING FBROWSER TOTAL TOTALPAGES)))) (LIST "Deleted: " (FB.COUNTER.STRING FBROWSER DEL DELPAGES)))) (DSPXPOSITION 0 COUNTERW) (DSPRIGHTMARGIN MAX.SMALLP COUNTERW) (LINELENGTH MAX.SMALLP COUNTERW) (SETQ MAXWIDTH 0) (|for| LAB |in| LABELS |do| (SETQ MAXWIDTH (IMAX MAXWIDTH (IPLUS (STRINGWIDTH (CAR LAB) COUNTERFONT) (STRINGWIDTH (CADR LAB) COUNTERFONT))))) (COND ((NOT (|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER)) (SETQ PAGESTRING "")) ((IGREATERP (PLUS MAXWIDTH (STRINGWIDTH (SETQ PAGESTRING " pages") COUNTERFONT)) THRESHOLDWIDTH) (* \; "Try a shorter word") (SETQ PAGESTRING " pgs"))) (COND ((IGREATERP (PLUS MAXWIDTH (STRINGWIDTH PAGESTRING COUNTERFONT)) THRESHOLDWIDTH) (* \; "The long labels are too long, so abbreviate them. Only have to do this for very narrow windows") (|for| LAB |in| LABELS |do| (RPLACA LAB (CONCAT (SUBSTRING (CAR LAB) 1 3) ": "))))) (|replace| (FILEBROWSER COUNTERPOSITIONS) |of| FBROWSER |with| (|for| LAB |in| LABELS |as| NEXTPOS |from| SECTIONWIDTH |by| SECTIONWIDTH |collect| (PRIN3 (CAR LAB) COUNTERW) (LIST (DSPXPOSITION NIL COUNTERW) (PROGN (PRIN3 (CADR LAB) COUNTERW) (PRIN3 PAGESTRING COUNTERW) (BLTSHADE WHITESHADE COUNTERW (SETQ HERE (DSPXPOSITION NIL COUNTERW)) 0 (IDIFFERENCE NEXTPOS HERE) HEIGHT (QUOTE REPLACE)) (DSPXPOSITION NEXTPOS COUNTERW) NEXTPOS)))) (|replace| (FILEBROWSER COUNTERPAGESTRING) |of| FBROWSER |with| PAGESTRING))) -) (FB.COUNTER.STRING -(LAMBDA (FBROWSER NFILES NPAGES) (* |bvm:| "11-Sep-85 11:44") (COND ((|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER) (CONCAT NFILES " / " NPAGES)) (T (MKSTRING NFILES)))) -) ) (DEFINEQ (FB.MAKEHEADINGWINDOW -(LAMBDA (BROWSERWINDOW WIDTH HEIGHT FONT) (* \; "Edited 22-Jan-88 17:45 by bvm") (LET ((HEADINGW (CREATEW (|create| REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ WIDTH HEIGHT _ HEIGHT) NIL 0 T))) (DSPFONT FONT HEADINGW) (FB.MAKERIGIDWINDOW HEADINGW) (ATTACHWINDOW HEADINGW BROWSERWINDOW (QUOTE TOP)) (WINDOWPROP HEADINGW (QUOTE PASSTOMAINCOMS) T) (* \; "Pass ALL window ops to main window, since we look sort of like a title bar") (DSPTEXTURE BLACKSHADE HEADINGW) (WINDOWPROP HEADINGW (QUOTE REPAINTFN) (FUNCTION FB.HEADINGW.REDISPLAYFN)) (WINDOWPROP HEADINGW (QUOTE RESHAPEFN) (FUNCTION FB.HEADINGW.RESHAPEFN)) (* \; "This is a white on black window") (DSPOPERATION (QUOTE INVERT) HEADINGW) (DSPFILL NIL BLACKSHADE (QUOTE REPLACE) HEADINGW) HEADINGW)) -) (FB.HEADINGW.REDISPLAYFN -(LAMBDA (WINDOW) (* |bvm:| "19-Sep-85 14:39") (FB.HEADINGW.DISPLAY (WINDOWPROP (WINDOWPROP WINDOW (QUOTE MAINWINDOW)) (QUOTE FILEBROWSER)) WINDOW)) -) (FB.HEADINGW.RESHAPEFN -(LAMBDA (WINDOW) (* \; "Edited 22-Jan-88 17:51 by bvm") (* |;;;| "Redraw the heading window after a reshape") (LET ((FBROWSER (WINDOWPROP (WINDOWPROP WINDOW (QUOTE MAINWINDOW)) (QUOTE FILEBROWSER)))) (CLEARW WINDOW) (FB.HEADINGW.DISPLAY FBROWSER WINDOW))) -) (FB.HEADINGW.DISPLAY -(LAMBDA (FBROWSER WINDOW) (* \; "Edited 30-Aug-94 19:42 by jds") (LET* ((STREAM (WINDOWPROP WINDOW (QUOTE DSP))) (CLIP (DSPCLIPPINGREGION NIL WINDOW)) (RMARG (|fetch| (REGION RIGHT) |of| CLIP)) (BORDER (WINDOWPROP (MAINWINDOW WINDOW) (QUOTE BORDER))) (NEXTPOS (+ BORDER (|fetch| (FILEBROWSER INFOSTART) |of| FBROWSER))) (DEPTH (|fetch| (FILEBROWSER FBDISPLAYEDDEPTH) |of| FBROWSER)) FORMAT) (DSPFILL CLIP BLACKSHADE (QUOTE REPLACE) STREAM) (* \; "Note: title window has no border, so add the main window's border width to all x computations here.") (DSPRIGHTMARGIN 32000 STREAM) (|if| (< (|fetch| (REGION LEFT) |of| CLIP) NEXTPOS) |then| (* \; "Some of \"Name (depth n)\" field may be visible.") (DSPXPOSITION (+ TB.LEFT.MARGIN BORDER) STREAM) (PRIN3 "Name" STREAM) (|if| (NEQ DEPTH 0) |then| (CL:FORMAT STREAM " (depth ~D)" DEPTH))) (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |until| (> NEXTPOS RMARG) |do| (DSPXPOSITION (|if| (LISTP (SETQ FORMAT (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC))) |then| (* \; "Right-justified integer field, so right-justify title") (- (+ NEXTPOS (CADR FORMAT)) (STRINGWIDTH (|fetch| (INFOFIELD INFOLABEL) |of| SPEC) STREAM)) |else| NEXTPOS) STREAM) (PRIN3 (|fetch| (INFOFIELD INFOLABEL) |of| SPEC) STREAM) (|add| NEXTPOS (|fetch| (INFOFIELD INFOWIDTH) |of| SPEC))))) -) ) (DEFINEQ (FB.ICONFN -(LAMBDA (WINDOW OLDICON POSITION) (* \; "Edited 30-Aug-94 19:48 by jds") (OR OLDICON (TITLEDICONW FB.ICONSPEC (|fetch| (FILEBROWSER PATTERN) |of| (WINDOWPROP WINDOW (QUOTE FILEBROWSER))) FB.ICONFONT POSITION NIL NIL (QUOTE FILE)))) -) (FB.INFOMENU.WHENSELECTEDFN -(LAMBDA (ITEM MENU KEY) (* |bvm:| "18-Sep-85 11:51") (LET* ((INFO (CADR ITEM)) (WINDOW (WINDOWPROP (WFROMMENU MENU) (QUOTE MAINWINDOW))) (BROWSER (WINDOWPROP WINDOW (QUOTE FILEBROWSER))) (CHOSEN (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER))) (COND ((FMEMB INFO CHOSEN) (SHADEITEM ITEM MENU WHITESHADE) (SETQ CHOSEN (REMOVE INFO CHOSEN))) (T (SHADEITEM ITEM MENU FB.INFOSHADE) (SETQ CHOSEN (CONS INFO CHOSEN)))) (|replace| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER |with| CHOSEN))) -) (FB.CLOSEFN -(LAMBDA (TBROWSER WINDOW FLG) (* \; "Edited 27-Jan-88 23:52 by bvm") (* |;;| "did you really want to close up shop?") (RESETLST (COND ((NOT (OBTAIN.MONITORLOCK (|fetch| (FILEBROWSER FBLOCK) |of| (TB.USERDATA TBROWSER)) T T)) (* \; "We're busy") (PROMPTPRINT (CONCAT "Can't " (L-CASE FLG) " window while browser is busy")) (QUOTE DON\'T)) ((NEQ (TB.NUMBER.OF.ITEMS TBROWSER (QUOTE DELETED)) 0) (* \; "There are deleted items. Shall we expunge?") (SELECTQ (MENU (FB.EXPUNGE?.MENU)) (EXPUNGE (* \; "Do expunge in another process, not here in mouse") (FUNCTION FB.CLOSE&EXPUNGE)) (NOEXPUNGE NIL) (QUOTE DON\'T)))))) -) (FB.EXPUNGE?.MENU -(LAMBDA NIL (* \; "Edited 1-Feb-88 15:25 by bvm:") (OR FB.EXPUNGE?MENU (SETQ FB.EXPUNGE?MENU (|create| MENU ITEMS _ FB.CLOSE.MENU.ITEMS MENUROWS _ 2 CENTERFLG _ T TITLE _ "Do what with deleted files?" MENUFONT _ FB.BROWSERFONT)))) -) (FB.AFTERCLOSEFN -(LAMBDA (TBROWSER WINDOW) (* |bvm:| "12-Sep-85 15:12") (* |;;;| "Snap circularities before window vanishes") (LET ((FBROWSER (WINDOWPROP WINDOW (QUOTE FILEBROWSER) NIL))) (|replace| (FILEBROWSER TABLEBROWSER) |of| FBROWSER |with| NIL) (TB.USERDATA TBROWSER NIL))) -) (FB.CLOSE&EXPUNGE -(LAMBDA (TBROWSER WINDOW FLG) (* \; "Edited 1-Feb-88 16:37 by bvm:") (LET ((BROWSER (TB.USERDATA TBROWSER)) MENU ITEM) (|find| W |in| (ATTACHEDWINDOWS WINDOW) |suchthat| (AND (SETQ MENU (CAR (WINDOWPROP W (QUOTE MENU)))) (EQ 1 (|fetch| (MENU MENUCOLUMNS) |of| MENU)))) (SETQ ITEM (ASSOC (QUOTE |Expunge|) (|fetch| (MENU ITEMS) |of| MENU))) (RESETLST (FB.MAKE.BROWSER.BUSY BROWSER ITEM MENU) (COND ((FB.EXPUNGECOMMAND BROWSER NIL NIL NIL FLG) (* |;;| "Expunge succeeded. Unshade the Expunge item and get rid of Abort before we shrink, or else they will still be shaded/Open when we expand") (FB.FINISH.COMMAND BROWSER ITEM MENU) (TB.FINISH.CLOSE TBROWSER (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER) FLG)))))) -) ) (DEFINEQ (FB.HARDCOPY.DIRECTORY -(LAMBDA (WINDOW IMAGESTREAM) (* \; "Edited 30-Aug-94 19:42 by jds") (RESETLST (LET ((FBROWSER (WINDOWPROP WINDOW (QUOTE FILEBROWSER))) (TBROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) (SCALE (DSPSCALE NIL IMAGESTREAM)) (RMARG (DSPRIGHTMARGIN MAX.SMALLP IMAGESTREAM)) (LMARG (DSPLEFTMARGIN NIL IMAGESTREAM)) (MAXNAMEWIDTH 0) (MAINFONT FB.HARDCOPY.FONT) (DIRFONT (OR FB.HARDCOPY.DIRECTORY.FONT ITALICFONT)) FDATA INFO W LABEL COLUMNSPECS INFOLMARG PROPS FILES TITLE PAD DATEWIDTH) (ALLOW.BUTTON.EVENTS) (* \; "Ensure that we are no longer the mouse process (should be redundant)") (FB.MAKE.BROWSER.BUSY FBROWSER) (* \; "Grab the browser, so it doesn't change out from under us") (FB.ALLOW.ABORT FBROWSER) (* \; "Enable abort button") (FB.PROMPTWPRINT FBROWSER T "Producing hardcopy listing of directory...") (|if| MAINFONT |then| (* \; "User-settable font for listing to appear in") (DSPFONT MAINFONT IMAGESTREAM)) (SETQ MAINFONT (DSPFONT NIL IMAGESTREAM)) (* \; "Get coerced font, or default") (SETQ TITLE (CONCAT "Directory of " (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER))) (STREAMPROP IMAGESTREAM (QUOTE PRINTOPTIONS) (LIST* (QUOTE DOCUMENT.NAME) TITLE (STREAMPROP IMAGESTREAM (QUOTE PRINTOPTIONS)))) (* \; "Give the document a nice name") (FB.HARDCOPY.PRINT.TITLE (CONCAT "Directory of " (WINDOWPROP (|fetch| (FILEBROWSER COUNTERWINDOW) |of| FBROWSER) (QUOTE TITLE))) IMAGESTREAM LMARG RMARG) (|if| (|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER) |then| (FB.HARDCOPY.PRINT.TITLE (CONCAT (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER) " files in " (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) " pages") IMAGESTREAM LMARG RMARG)) (SETQ PAD (TIMES SCALE 12)) (* \; "Space between columns") (|for| ITEM |in| (SETQ FILES (TB.COLLECT.ITEMS TBROWSER)) |unless| (|fetch| (FBFILEDATA DIRECTORYP) |of| (SETQ FDATA (|fetch| TIDATA |of| ITEM))) |do| (SETQ MAXNAMEWIDTH (IMAX (STRINGWIDTH (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) MAINFONT) MAXNAMEWIDTH))) (SETQ COLUMNSPECS (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |as| INDEX |from| 0 |bind| PROTO |collect| (* \; "For each bit of info to print, compute how much space we expect it to need. Second slot filled in below") (LIST* (+ PAD (|if| (SETQ PROTO (|fetch| (INFOFIELD INFOPROTOTYPE) |of| SPEC)) |then| (STRINGWIDTH PROTO IMAGESTREAM) |elseif| (EQ (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC) (QUOTE DATE)) |then| (OR DATEWIDTH (SETQ DATEWIDTH (FB.HARDCOPY.MAXWIDTH FILES INDEX MAINFONT T))) |else| (FB.HARDCOPY.MAXWIDTH FILES INDEX MAINFONT))) NIL SPEC))) (SETQ INFOLMARG (- RMARG (|for| PAIR |in| COLUMNSPECS |sum| (CAR PAIR)))) (LET ((NAMERIGHTMARG (+ LMARG MAXNAMEWIDTH PAD))) (|if| (< NAMERIGHTMARG INFOLMARG) |then| (* \; "Enough space for name plus all info with room left over") (SETQ INFOLMARG NAMERIGHTMARG) |elseif| (> INFOLMARG LMARG) |then| (* \; "Ok, there's enough space for info, though it might end up on a separate line from file name") |else| (* \; "Ugh, want to print more info than fits on a line. Punt") (SETQ INFOLMARG NAMERIGHTMARG) (DSPRIGHTMARGIN RMARG IMAGESTREAM) (* \; "make it wrap after all"))) (LET ((FIRSTINFOCOLUMN INFOLMARG)) (|for| PAIR |in| COLUMNSPECS |do| (* \; "Print headers") (SETQ LABEL (|fetch| (INFOFIELD INFOLABEL) |of| (CDDR PAIR))) (SETQ W (FIXR (CAR PAIR))) (DSPXPOSITION (+ FIRSTINFOCOLUMN (IQUOTIENT (- (- W PAD) (STRINGWIDTH LABEL IMAGESTREAM)) 2)) IMAGESTREAM) (* \; "Center the label") (PRIN3 LABEL IMAGESTREAM) (RPLACA PAIR (PROG1 FIRSTINFOCOLUMN (|add| FIRSTINFOCOLUMN W))) (* \; "First element is left position of the entry ") (|if| (|fetch| (INFOFIELD INFOFORMAT) |of| (CDDR PAIR)) |then| (* \; "Second element is right margin (for right-justified items)") (RPLACA (CDR PAIR) (- FIRSTINFOCOLUMN PAD)))) (TERPRI IMAGESTREAM) (TERPRI IMAGESTREAM)) (|for| ITEM |in| FILES |bind| FILEINFO INFO FORMAT HERE NEXT |do| (SETQ FDATA (|fetch| TIDATA |of| ITEM)) (|if| (|fetch| (FBFILEDATA DIRECTORYP) |of| FDATA) |then| (DSPFONT DIRFONT IMAGESTREAM) (DSPXPOSITION (+ LMARG (TIMES SCALE 16)) IMAGESTREAM) (PRIN3 (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) IMAGESTREAM) (DSPFONT MAINFONT IMAGESTREAM) |else| (PRIN3 (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) IMAGESTREAM) (|if| COLUMNSPECS |then| (SETQ FILEINFO (|fetch| (FBFILEDATA FILEINFO) |of| FDATA)) (|if| (AND (> (SETQ HERE (DSPXPOSITION NIL IMAGESTREAM)) INFOLMARG) (OR (NULL (SETQ NEXT (CADR (CAR COLUMNSPECS)))) (> HERE NEXT) (AND (SETQ INFO (CAR FILEINFO)) (> (+ HERE (TIMES SCALE 6)) (- NEXT (STRINGWIDTH INFO MAINFONT)))))) |then| (* \; "name overran start of info--go to next line. The complex second clause lets us cheat in the case where the first info column is right-justified and will turn out to be short enough to leave space") (TERPRI IMAGESTREAM)) (|for| PAIR |in| COLUMNSPECS |as| INFO |in| FILEINFO |do| (DSPXPOSITION (COND ((SETQ NEXT (CADR PAIR)) (* \; "Get numbers to line up right justified") (- NEXT (STRINGWIDTH INFO MAINFONT))) (T (CAR PAIR))) IMAGESTREAM) (|if| INFO |then| (PRIN3 INFO IMAGESTREAM))))) (TERPRI IMAGESTREAM) (BLOCK)) (FB.PROMPTWPRINT FBROWSER "done") (DSPRIGHTMARGIN RMARG IMAGESTREAM)))) -) (FB.HARDCOPY.PRINT.TITLE -(LAMBDA (TITLE IMAGESTREAM LMARG RMARG) (* \; "Edited 5-Mar-87 17:59 by bvm:") (DSPXPOSITION (+ LMARG (IQUOTIENT (- RMARG (+ LMARG (STRINGWIDTH TITLE IMAGESTREAM))) 2)) IMAGESTREAM) (|printout| IMAGESTREAM TITLE T T)) -) (FB.HARDCOPY.MAXWIDTH -(LAMBDA (FILES ATTRINDEX FONT DATEP) (* \; "Edited 27-Jan-88 13:10 by bvm") (* |;;| "Compute maximum width of values of the ATTRIBUTE prop of each of the items in FILES.") (* |;;| "If DATEP is true, we assume all dates are created equal, and just return the first one") (|if| (AND DATEP (NEQ (CHARWIDTH (CHARCODE W) FONT) (CHARWIDTH (CHARCODE \i) FONT))) |then| (* \; "Variable-width font, let's compute it for real") (SETQ DATEP NIL)) (|for| ITEM |in| FILES |bind| (MAXWIDTH _ 0) INFO WIDTH |when| (AND (SETQ INFO (CL:NTH ATTRINDEX (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| ITEM)))) (> (SETQ WIDTH (STRINGWIDTH INFO FONT)) MAXWIDTH)) |do| (|if| DATEP |then| (RETURN WIDTH)) (SETQ MAXWIDTH WIDTH) |finally| (RETURN MAXWIDTH))) -) ) (DECLARE\: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) TABLEBROWSERDECLS) (DECLARE\: EVAL@COMPILE (RECORD INFOFIELD (INFONAME INFOLABEL INFOWIDTH INFOFORMAT INFOPROTOTYPE)) (DATATYPE FBFILEDATA ((FILENAME POINTER) (* \; "Full name of this file") (FILEINFO POINTER) (* \; "Plist of attributes") (VERSIONLESSNAME POINTER) (* \; "FILENAME sans version") (DIRECTORYP FLAG) (* \; "True if it's a directory line") (HASDIRPREFIX FLAG) (* \;  "True if it has a directory prefix beyond that in common to all the files") (DIRECTORYFILEP FLAG) (* \;  "True if the \"file\" in this item is actually a subdirectory") (SIZE POINTER) (* \; "Size of file, for stats") (FILEDEPTH BYTE) (* \;  "Number of levels of subdirectory beneath the main pattern--zero for files at that level") (SORTVALUE POINTER) (* \;  "Cached value by which we are sorting the dir.") (SUBDIREND WORD) (* \;  "Index of last char in subdirectory, or zero if HASDIRPREFIX is false") (STARTOFPNAME WORD) (* \;  "Start of name for printing purposes. Same as STARTOFNAME when browser sorted by name") (VERSION WORD) (* \; "Version, or zero if none") (STARTOFNAME WORD) (* \;  "Index beyond all directory fields") DUMMY) (ACCESSFNS FBFILEDATA ((PRINTNAME (SUBSTRING (FETCH (FBFILEDATA FILENAME ) OF DATUM) (FETCH (FBFILEDATA STARTOFPNAME ) OF DATUM))) (SUBDIRECTORY (SUBSTRING (FETCH (FBFILEDATA FILENAME) OF DATUM) 1 (FETCH (FBFILEDATA SUBDIREND ) OF DATUM)))))) (DATATYPE FILEBROWSER ((NOSUBDIRECTORIES FLAG) (* \;  "True if we don't want separate subdirectory lines -- subdirs then included in name") (NSPATTERN? FLAG) (* \; "True if host is an ns host") (SHOWUNDELETED? FLAG) (* \;  "True if counter window should show `Undeleted' rather than `Total' counts") (PATTERNPARSED? FLAG) (* \;  "True if PREPAREDPATTERN, NAMESTART, DIRECTORYSTART are valid") (SORTBYDATE FLAG) (* \;  "True if SORTATTRIBUTE is one of the date attributes") (FBREADY FLAG) (* \; "False while FB is enumerating.") (ABORTING FLAG) (* \;  "True if enumeration is being aborted") (FIXEDTITLE FLAG) (* \; "True if caller supplied title") (FBCOMPUTEDDEPTH BYTE) (* \;  "Depth at the time we enumerated directory (zero for infinite)") (FBDISPLAYEDDEPTH BYTE) (* \;  "Depth we are currently displaying (zero for infinite)") (TABLEBROWSER POINTER) (* \;  "Pointer to TABLEBROWSER object controlling the browser") (BROWSERWINDOW POINTER) (* \; "Main window") (COUNTERWINDOW POINTER) (* \;  "Window that counts files, pages, deletions") (HEADINGWINDOW POINTER) (* \;  "Window with headings for browser columns") (INFOMENUW POINTER) (* \;  "Window containing choices for info to be displayed, or NIL if none yet") (PROMPTWINDOW POINTER) (* \; "GETPROMPTWINDOW BROWSERWINDOW") (INFODISPLAYED POINTER) (* \;  "List of attribute specs to be displayed") (PATTERN POINTER) (* \;  "Directory pattern being enumerated") (PREPAREDPATTERN POINTER) (* \; "DIRECTORY.MATCH.SETUP of same") (SEEWINDOW POINTER) (* \;  "Primary window used by FAST SEE command") (BROWSERFONT POINTER) (* \; "Font of BROWSERWINDOW") (SORTBY POINTER) (* \;  "Sorting function or NIL for default sort") (NAMESTART WORD) (* \;  "Index of first character in file name beyond the common prefix shared by all") (DIRECTORYSTART WORD) (* \;  "Index of first character of directory in file names") (INFOSTART WORD) (* \;  "X position in browser where first col of info is displayed") (NAMEOVERHEAD WORD) (* \;  "This plus width of name gives is how much to allow before INFOSTART") (OVERFLOWSPACING WORD) (* \;  "Increment between sizes considered for INFOSTART") (DIGITWIDTH WORD) (TOTALFILES WORD) (* \;  "Total number of files, deleted files, pages, deleted pages at the moment") (DELETEDFILES WORD) (TOTALPAGES POINTER) (DELETEDPAGES POINTER) (PAGECOUNT? POINTER) (* \;  "True if INFOCHOICES includes SIZE or LENGTH, so that we can count pages") (COUNTERPOSITIONS POINTER) (* \;  "List of pairs (left right) describing regions where the values of the counters are displayed") (COUNTERPAGESTRING POINTER) (* \;  "String to print after file/page count") (OVERFLOWWIDTHS POINTER) (* \;  "List of (xpos occurrences) describing files whose names exceed default INFOSTART") (INFOMENUCHOICES POINTER) (* \;  "Selections user has made in Info window, not necessarily the info currently displayed") (UPDATEPROC POINTER) (* \;  "Process doing an Update (Recompute)") (DEFAULTDIR POINTER) (* \;  "Default directory for destination of Copy/Rename") (SORTATTRIBUTE POINTER) (* \;  "Attribute being sorted on, or NIL if by name") (SORTMENU POINTER) (FBLOCK POINTER) (* \;  "Lock acquired by filebrowser operations") (SORTINDEX WORD) (* \;  "Index (zero-based) in file info of the sort attribute") (SIZEINDEX WORD) (* \; "Index of size attribute") (FBDEPTH POINTER) (* \;  "Enumeration depth, or NIL for default") (ABORTWINDOW POINTER) (* \;  "Dotted pair of (abortwindow . menuw) for this browser's abort window.") DUMMY)) ) (/DECLAREDATATYPE 'FBFILEDATA '(POINTER POINTER POINTER FLAG FLAG FLAG POINTER BYTE POINTER WORD WORD WORD WORD POINTER) '((FBFILEDATA 0 POINTER) (FBFILEDATA 2 POINTER) (FBFILEDATA 4 POINTER) (FBFILEDATA 4 (FLAGBITS . 0)) (FBFILEDATA 4 (FLAGBITS . 16)) (FBFILEDATA 4 (FLAGBITS . 32)) (FBFILEDATA 6 POINTER) (FBFILEDATA 8 (BITS . 7)) (FBFILEDATA 10 POINTER) (FBFILEDATA 9 (BITS . 15)) (FBFILEDATA 12 (BITS . 15)) (FBFILEDATA 13 (BITS . 15)) (FBFILEDATA 14 (BITS . 15)) (FBFILEDATA 16 POINTER)) '18) (/DECLAREDATATYPE 'FILEBROWSER '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG BYTE BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER) '((FILEBROWSER 0 (FLAGBITS . 0)) (FILEBROWSER 0 (FLAGBITS . 16)) (FILEBROWSER 0 (FLAGBITS . 32)) (FILEBROWSER 0 (FLAGBITS . 48)) (FILEBROWSER 0 (FLAGBITS . 64)) (FILEBROWSER 0 (FLAGBITS . 80)) (FILEBROWSER 0 (FLAGBITS . 96)) (FILEBROWSER 0 (FLAGBITS . 112)) (FILEBROWSER 0 (BITS . 135)) (FILEBROWSER 1 (BITS . 7)) (FILEBROWSER 2 POINTER) (FILEBROWSER 4 POINTER) (FILEBROWSER 6 POINTER) (FILEBROWSER 8 POINTER) (FILEBROWSER 10 POINTER) (FILEBROWSER 12 POINTER) (FILEBROWSER 14 POINTER) (FILEBROWSER 16 POINTER) (FILEBROWSER 18 POINTER) (FILEBROWSER 20 POINTER) (FILEBROWSER 22 POINTER) (FILEBROWSER 24 POINTER) (FILEBROWSER 26 (BITS . 15)) (FILEBROWSER 27 (BITS . 15)) (FILEBROWSER 28 (BITS . 15)) (FILEBROWSER 29 (BITS . 15)) (FILEBROWSER 30 (BITS . 15)) (FILEBROWSER 31 (BITS . 15)) (FILEBROWSER 32 (BITS . 15)) (FILEBROWSER 33 (BITS . 15)) (FILEBROWSER 34 POINTER) (FILEBROWSER 36 POINTER) (FILEBROWSER 38 POINTER) (FILEBROWSER 40 POINTER) (FILEBROWSER 42 POINTER) (FILEBROWSER 44 POINTER) (FILEBROWSER 46 POINTER) (FILEBROWSER 48 POINTER) (FILEBROWSER 50 POINTER) (FILEBROWSER 52 POINTER) (FILEBROWSER 54 POINTER) (FILEBROWSER 56 POINTER) (FILEBROWSER 58 (BITS . 15)) (FILEBROWSER 59 (BITS . 15)) (FILEBROWSER 60 POINTER) (FILEBROWSER 62 POINTER) (FILEBROWSER 64 POINTER)) '66) (DECLARE\: EVAL@COMPILE (RPAQQ FB.MORE.BORDER 8) (RPAQQ FB.NULL.VERSION 0) (CONSTANTS FB.MORE.BORDER FB.NULL.VERSION) ) (DECLARE\: EVAL@COMPILE (PUTPROPS NULL.VERSIONP MACRO ((V) (EQ V 0))) (PUTPROPS NULL.DIRECTORYP MACRO ((FILEDATA) (EQ (FETCH (FBFILEDATA SUBDIREND) OF FILEDATA) 0))) (PUTPROPS EQ.DIRECTORYP MACRO (OPENLAMBDA (FD1 FD2) (STRING-EQUAL (|fetch| (FBFILEDATA FILENAME) |of| FD1) (|fetch| (FBFILEDATA FILENAME) |of| FD2) :END1 (|fetch| (FBFILEDATA SUBDIREND) |of| FD1) :END2 (|fetch| (FBFILEDATA SUBDIREND) |of| FD2)))) (PUTPROPS NULL.FIELDP MACRO (OPENLAMBDA (STR) (OR (NULL STR) (EQ (NCHARS STR) 0)))) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FB.ICONFONT FB.BROWSERFONT FB.PROMPTFONT FB.MENUFONT FB.HARDCOPY.FONT FB.HARDCOPY.DIRECTORY.FONT FB.EXPUNGE?MENU FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.MENU.ITEMS FB.DEFAULT.INFO FB.INFOSHADE FB.INFO.MENU.ITEMS FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE DIRCOMMANDS FB.PROMPTLINES FB.INFO.FIELDS |WindowTitleDisplayStream| FB.ICONSPEC FB.DEFAULT.NAME.WIDTH FB.OVERFLOW.MAXABSOLUTE FB.OVERFLOW.MAXFRAC FB.DEFAULT.EDITOR FB.BROWSER.DIRECTORY.FONT ITALICFONT PRINTFILETYPES) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (/DECLAREDATATYPE 'FILEBROWSER '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG BYTE BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER) '((FILEBROWSER 0 (FLAGBITS . 0)) (FILEBROWSER 0 (FLAGBITS . 16)) (FILEBROWSER 0 (FLAGBITS . 32)) (FILEBROWSER 0 (FLAGBITS . 48)) (FILEBROWSER 0 (FLAGBITS . 64)) (FILEBROWSER 0 (FLAGBITS . 80)) (FILEBROWSER 0 (FLAGBITS . 96)) (FILEBROWSER 0 (FLAGBITS . 112)) (FILEBROWSER 0 (BITS . 135)) (FILEBROWSER 1 (BITS . 7)) (FILEBROWSER 2 POINTER) (FILEBROWSER 4 POINTER) (FILEBROWSER 6 POINTER) (FILEBROWSER 8 POINTER) (FILEBROWSER 10 POINTER) (FILEBROWSER 12 POINTER) (FILEBROWSER 14 POINTER) (FILEBROWSER 16 POINTER) (FILEBROWSER 18 POINTER) (FILEBROWSER 20 POINTER) (FILEBROWSER 22 POINTER) (FILEBROWSER 24 POINTER) (FILEBROWSER 26 (BITS . 15)) (FILEBROWSER 27 (BITS . 15)) (FILEBROWSER 28 (BITS . 15)) (FILEBROWSER 29 (BITS . 15)) (FILEBROWSER 30 (BITS . 15)) (FILEBROWSER 31 (BITS . 15)) (FILEBROWSER 32 (BITS . 15)) (FILEBROWSER 33 (BITS . 15)) (FILEBROWSER 34 POINTER) (FILEBROWSER 36 POINTER) (FILEBROWSER 38 POINTER) (FILEBROWSER 40 POINTER) (FILEBROWSER 42 POINTER) (FILEBROWSER 44 POINTER) (FILEBROWSER 46 POINTER) (FILEBROWSER 48 POINTER) (FILEBROWSER 50 POINTER) (FILEBROWSER 52 POINTER) (FILEBROWSER 54 POINTER) (FILEBROWSER 56 POINTER) (FILEBROWSER 58 (BITS . 15)) (FILEBROWSER 59 (BITS . 15)) (FILEBROWSER 60 POINTER) (FILEBROWSER 62 POINTER) (FILEBROWSER 64 POINTER)) '66) (/DECLAREDATATYPE 'FBFILEDATA '(POINTER POINTER POINTER FLAG FLAG FLAG POINTER BYTE POINTER WORD WORD WORD WORD POINTER) '((FBFILEDATA 0 POINTER) (FBFILEDATA 2 POINTER) (FBFILEDATA 4 POINTER) (FBFILEDATA 4 (FLAGBITS . 0)) (FBFILEDATA 4 (FLAGBITS . 16)) (FBFILEDATA 4 (FLAGBITS . 32)) (FBFILEDATA 6 POINTER) (FBFILEDATA 8 (BITS . 7)) (FBFILEDATA 10 POINTER) (FBFILEDATA 9 (BITS . 15)) (FBFILEDATA 12 (BITS . 15)) (FBFILEDATA 13 (BITS . 15)) (FBFILEDATA 14 (BITS . 15)) (FBFILEDATA 16 POINTER)) '18) (ADDTOVAR SYSTEMRECLST (DATATYPE FILEBROWSER ((NOSUBDIRECTORIES FLAG) (NSPATTERN? FLAG) (SHOWUNDELETED? FLAG) (PATTERNPARSED? FLAG) (SORTBYDATE FLAG) (FBREADY FLAG) (ABORTING FLAG) (FIXEDTITLE FLAG) (FBCOMPUTEDDEPTH BYTE) (FBDISPLAYEDDEPTH BYTE) (TABLEBROWSER POINTER) (BROWSERWINDOW POINTER) (COUNTERWINDOW POINTER) (HEADINGWINDOW POINTER) (INFOMENUW POINTER) (PROMPTWINDOW POINTER) (INFODISPLAYED POINTER) (PATTERN POINTER) (PREPAREDPATTERN POINTER) (SEEWINDOW POINTER) (BROWSERFONT POINTER) (SORTBY POINTER) (NAMESTART WORD) (DIRECTORYSTART WORD) (INFOSTART WORD) (NAMEOVERHEAD WORD) (OVERFLOWSPACING WORD) (DIGITWIDTH WORD) (TOTALFILES WORD) (DELETEDFILES WORD) (TOTALPAGES POINTER) (DELETEDPAGES POINTER) (PAGECOUNT? POINTER) (COUNTERPOSITIONS POINTER) (COUNTERPAGESTRING POINTER) (OVERFLOWWIDTHS POINTER) (INFOMENUCHOICES POINTER) (UPDATEPROC POINTER) (DEFAULTDIR POINTER) (SORTATTRIBUTE POINTER) (SORTMENU POINTER) (FBLOCK POINTER) (SORTINDEX WORD) (SIZEINDEX WORD) (FBDEPTH POINTER) (ABORTWINDOW POINTER) DUMMY)) (DATATYPE FBFILEDATA ((FILENAME POINTER) (FILEINFO POINTER) (VERSIONLESSNAME POINTER) (DIRECTORYP FLAG) (HASDIRPREFIX FLAG) (DIRECTORYFILEP FLAG) (SIZE POINTER) (FILEDEPTH BYTE) (SORTVALUE POINTER) (SUBDIREND WORD) (STARTOFPNAME WORD) (VERSION WORD) (STARTOFNAME WORD) DUMMY)) ) (DECLARE\: DONTEVAL@LOAD DOCOPY (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T) (ADDTOVAR *ATTACHED-WINDOW-COMMAND-SYNONYMS* (HARDCOPYIMAGEW.TOFILE . HARDCOPYIMAGEW) (HARDCOPYIMAGEW.TOPRINTER . HARDCOPYIMAGEW)) (ADDTOVAR |BackgroundMenuCommands| ("FileBrowser" '(FILEBROWSER) "Opens a filebrowser window; prompts for pattern")) (RPAQQ |BackgroundMenu| NIL) ) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA FB) (ADDTOVAR NLAML ) (ADDTOVAR LAMA FB.PROMPTW.FORMAT FB.PROMPTWPRINT) ) (PUTPROPS FILEBROWSER COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1993 1994 1999 2000 2001)) (DECLARE\: DONTCOPY (FILEMAP (NIL (20917 33529 (FB 20927 . 21482) (FB.COPYBINARYCOMMAND 21484 . 21672) (FB.COPYTEXTCOMMAND 21674 . 21858) (FILEBROWSER 21860 . 28102) (FB.TABLEBROWSER 28104 . 28266) (FB.SELECTEDFILES 28268 . 28722) (FB.FETCHFILENAME 28724 . 28959) (FB.PROMPTWPRINT 28961 . 29412) (FB.PROMPTW.FORMAT 29414 . 29935) (FB.PROMPTFORINPUT 29937 . 32189) (FB.YES-OR-NO-P 32191 . 32751) (FB.ALLOW.ABORT 32753 . 33328) (\\FB.HARDCOPY.TOFILE.EXTENSION 33330 . 33527)) (33553 34215 (FB.STARTUP 33563 . 33858) ( FB.MAKERIGIDWINDOW 33860 . 34213)) (34216 37235 (FB.PRINTFN 34226 . 37086) (FB.COPYFN 37088 . 37233)) (37285 40702 (FB.MENU.WHENSELECTEDFN 37295 . 37589) (FB.COMMANDSELECTEDFN 37591 . 38452) (FB.SUBITEMP 38454 . 38766) (FB.MAKE.BROWSER.BUSY 38768 . 39176) (FB.FINISH.COMMAND 39178 . 40097) ( FB.HANDLE.ABORT.BUTTON 40099 . 40700)) (40703 43411 (FB.DELETECOMMAND 40713 . 40913) (FB.DELVERCOMMAND 40915 . 42294) (FB.IS.NOT.SUBDIRECTORY.ITEM 42296 . 42423) (FB.DELVER.FILES 42425 . 43001) ( FB.DELETE.FILE 43003 . 43409)) (43412 44242 (FB.UNDELETECOMMAND 43422 . 43626) (FB.UNDELETEALLCOMMAND 43628 . 43826) (FB.UNDELETE.FILE 43828 . 44240)) (44243 56381 (FB.COPYCOMMAND 44253 . 44411) ( FB.RENAMECOMMAND 44413 . 44577) (FB.COPY/RENAME.COMMAND 44579 . 45102) (FB.COPY/RENAME.ONE 45104 . 46202) (FB.COPY/RENAME.MANY 46204 . 49315) (FB.MERGE.DIRECTORIES 49317 . 49554) (FB.GREATEST.PREFIX 49556 . 50216) (FB.MAYBE.INSERT.FILE 50218 . 53907) (FB.GET.NEW.FILE.SPEC 53909 . 55720) ( FB.CANONICAL.DIRECTORY 55722 . 56379)) (56382 59993 (FB.HARDCOPYCOMMAND 56392 . 57007) ( FB.HARDCOPY.TOFILE 57009 . 59991)) (59994 64171 (FB.EDITCOMMAND 60004 . 61295) (FB.EDITLISPFILE 61297 . 61891) (FB.BROWSECOMMAND 61893 . 64169)) (64172 71205 (FB.FASTSEECOMMAND 64182 . 65775) ( FB.FASTSEE.ONEFILE 65777 . 68924) (FB.SEEFULLFN 68926 . 70548) (FB.SEEBUTTONFN 70550 . 71203)) (71206 72336 (FB.LOADCOMMAND 71216 . 71523) (FB.COMPILECOMMAND 71525 . 71866) (FB.OPERATE.ON.FILES 71868 . 72334)) (72337 97097 (FB.UPDATECOMMAND 72347 . 72506) (FB.MAYBE.EXPUNGE 72508 . 73103) ( FB.UPDATEBROWSERITEMS 73105 . 79551) (FB.DATE 79553 . 79949) (FB.ADJUST.DATE.WIDTH 79951 . 81294) ( FB.SET.BROWSER.TITLE 81296 . 81892) (FB.MAYBE.WIDEN.NAMES 81894 . 82870) (FB.SET.DEFAULT.NAME.WIDTH 82872 . 83457) (FB.CREATE.FILEBUCKET 83459 . 87084) (FB.CHECK.NAME.LENGTH 87086 . 88583) ( FB.ADD.FILEGROUP 88585 . 89565) (FB.INSERT.DIRECTORY 89567 . 89776) (FB.MAKE.SUBDIRECTORY.ITEM 89778 . 90590) (FB.ADD.FILE 90592 . 91042) (FB.INSERT.FILE 91044 . 92941) (FB.ANALYZE.PATTERN 92943 . 95612 ) (FB.CANONICALIZE.PATTERN 95614 . 96360) (FB.GETALLFILEINFO 96362 . 97095)) (97098 101508 ( FB.SORT.VERSIONS 97108 . 98201) (FB.DECREASING.VERSION 98203 . 98593) (FB.INCREASING.VERSION 98595 . 98982) (FB.NAMES.DECREASING.VERSION 98984 . 99534) (FB.NAMES.INCREASING.VERSION 99536 . 100081) ( FB.DECREASING.NUMERIC.ATTR 100083 . 100577) (FB.INCREASING.NUMERIC.ATTR 100579 . 101067) ( FB.ALPHABETIC.ATTR 101069 . 101506)) (101509 106088 (FB.SORTCOMMAND 101519 . 104531) ( FB.INSERT.SUBDIRECTORIES 104533 . 104960) (FB.GET.SORT.MENU 104962 . 106086)) (106089 114725 ( FB.EXPUNGECOMMAND 106099 . 107166) (FB.NEWPATTERNCOMMAND 107168 . 107435) (FB.NEWINFOCOMMAND 107437 . 108724) (FB.DEPTHCOMMAND 108726 . 109525) (FB.SHAPECOMMAND 109527 . 111464) (FB.REMOVE.FILE 111466 . 112646) (FB.COUNT.FILE.CHANGE 112648 . 113441) (FB.SETNEWPATTERN 113443 . 114189) (FB.GET.NEWPATTERN 114191 . 114548) (FB.OPTIONSCOMMAND 114550 . 114723)) (114760 115354 ( FB.INFOMENU.SHADEINITIALSELECTIONS 114770 . 115122) (FB.INFO.ITEM.NAMED 115124 . 115352)) (115355 120184 (FB.MAKECOUNTERWINDOW 115365 . 116044) (FB.COUNTERW.REDISPLAYFN 116046 . 116404) ( FB.UPDATE.COUNTERS 116406 . 117685) (FB.DISPLAY.COUNTERS 117687 . 119984) (FB.COUNTER.STRING 119986 . 120182)) (120185 122784 (FB.MAKEHEADINGWINDOW 120195 . 120964) (FB.HEADINGW.REDISPLAYFN 120966 . 121144) (FB.HEADINGW.RESHAPEFN 121146 . 121430) (FB.HEADINGW.DISPLAY 121432 . 122782)) (122785 125489 (FB.ICONFN 122795 . 123043) (FB.INFOMENU.WHENSELECTEDFN 123045 . 123568) (FB.CLOSEFN 123570 . 124200) (FB.EXPUNGE?.MENU 124202 . 124457) (FB.AFTERCLOSEFN 124459 . 124745) (FB.CLOSE&EXPUNGE 124747 . 125487 )) (125490 131674 (FB.HARDCOPY.DIRECTORY 125500 . 130650) (FB.HARDCOPY.PRINT.TITLE 130652 . 130901) ( FB.HARDCOPY.MAXWIDTH 130903 . 131672))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "27-Feb-2021 20:08:26"  |{DSK}kaplan>Local>medley3.5>git-medley>library>FILEBROWSER.;33| 261320 |changes| |to:| (FNS FB.EDITCOMMAND.ONEFILE FB.FINISH.COMMAND FB.MAKE.BROWSER.BUSY FB.EDITCOMMAND) |previous| |date:| "25-Feb-2021 13:24:50" |{DSK}kaplan>Local>medley3.5>git-medley>library>FILEBROWSER.;27|) ; Copyright (c) 1983-1991, 1993-1994, 1999-2001, 2021 by Venue & Xerox Corporation. (PRETTYCOMPRINT FILEBROWSERCOMS) (RPAQQ FILEBROWSERCOMS ((COMS (DECLARE\: EVAL@COMPILE DONTCOPY (P (CL:UNLESS (GETP 'EXPORTS.ALL 'FILE) (TERPRI T) (PRIN1 "NOTE: FILEBROWSER requires EXPORTS.ALL" T) (TERPRI T) (TERPRI T)))) (FILES ATTACHEDWINDOW ICONW TABLEBROWSER) (P (* |;;| "Set up for MODERNIZE windows, whether or not MODERNIZE is pre-loaded") (MOVD? 'NILL 'TOTOPW.MODERNIZE)) (* |;;| "JDS 11/94 FB.ICONSPEC is now an INITVAR so we can create smaller ones in profiles for, e.g., laptops.") (INITVARS (FB.EXPUNGE?MENU) (FB.BROWSERFONT DEFAULTFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT) (FB.PROMPTFONT LITTLEFONT) (FB.HARDCOPY.FONT) (FB.HARDCOPY.DIRECTORY.FONT) (FB.PROMPTLINES 3) (FB.MENUFONT MENUFONT) (FB.OVERFLOW.MAXABSOLUTE 30) (FB.OVERFLOW.MAXFRAC 0.06) (FB.DEFAULT.EDITOR 'TEDIT) (FB.DEFAULT.INFO '(SIZE CREATIONDATE AUTHOR))) (APPENDVARS (FONTVARS (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT LITTLEFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT))) (P (* |;;| "FONTSET fills in the variables in FONTVARS for us, so do it.") (FONTSET (FONTSET))) (ADDVARS (CACHEDMENUS FB.EXPUNGE?MENU)) (INITVARS (FB.MENU.ITEMS '((|Delete| FB.DELETECOMMAND "Marks selected files for deletion. (Use EXPUNGE to remove files from system)" (SUBITEMS ("Delete Selected Files" FB.DELETECOMMAND "Marks the selected files for deletion." ) ("Delete Old Versions" FB.DELVERCOMMAND "Marks for deletion old versions of all files in the browser. You specify how many versions to keep."))) (|Undelete| FB.UNDELETECOMMAND "Removes deletion mark for selected files" (SUBITEMS ("Undelete ALL Files" FB.UNDELETEALLCOMMAND "Removes deletion mark from all files in the browser" ))) (|Copy| FB.COPYCOMMAND "Copies selected files (prompts for new file name/directory)" (SUBITEMS ("Copy using TEXT FileType" FB.COPYTEXTCOMMAND "Forces the copying of selected files to be done as TEXT-files" ) ("Copy using BINARY FileType" FB.COPYBINARYCOMMAND "Forces the copying of selected files to be done as BINARY-files" ))) (|Rename| FB.RENAMECOMMAND "Renames (moves) selected files (prompts for new name/directory)" ) (|Hardcopy| FB.HARDCOPYCOMMAND "Produces hardcopy of selected files on your default printer" (SUBITEMS ("To a file" (FB.HARDCOPYCOMMAND FILE) "Generates a hardcopy master of selected file; prompts for filename and format" ) ("To a printer" (FB.HARDCOPYCOMMAND PRINTER) "Sends hardcopy of selected files to a printer of your choosing" ))) (|See| (FB.EDITCOMMAND READONLY) "Displays selected files one at a time in a separate window" (SUBITEMS ("Fast SEE Pretty" FB.FASTSEECOMMAND "Views file quickly, uses font information, no scrolling backwards" ) ("Fast SEE Unformatted" (FB.FASTSEECOMMAND T) "Views file quickly, shows raw characters, no scrolling backwards" ) ("Scrollable & Pretty" (FB.EDITCOMMAND READONLY) "Views file with font information in a fully scrollable window" ) ("FileBrowse" FB.BROWSECOMMAND "Recursively call FileBrowser on the selected subdirectory" ))) (|Edit| FB.EDITCOMMAND "Calls an editor on the selected files (use submenu to specify editor)" (SUBITEMS ("TEdit" (FB.EDITCOMMAND TEDIT) "Calls TEdit (text editor) on selected files" ) ("Lisp Edit" (FB.EDITCOMMAND LISP) "Calls Lisp editor on selected files")) ) (|Load| FB.LOADCOMMAND "LOADs selected files" (SUBITEMS ("IL:LOAD" FB.LOADCOMMAND "LOADs selected files") ("CL:LOAD" (FB.LOADCOMMAND CL:LOAD) "Performs CL:LOAD on selected files") ("Load PROP" (FB.LOADCOMMAND PROP) "Loads the selected files with LDFLG = PROP" ) ("Load SYSLOAD" (FB.LOADCOMMAND SYSLOAD) "System-loads the files (fast but not undoable)" ) (LOADFROM (FB.LOADCOMMAND LOADFROM) "Performs LOADFROM on selected files") (LOADCOMP (FB.LOADCOMMAND LOADCOMP) "Performs LOADCOMP on selected files")) ) (|Compile| FB.COMPILECOMMAND "Compiles selected LISP source files using default compiler" (SUBITEMS (TCOMPL (FB.COMPILECOMMAND TCOMPL) "Calls TCOMPL on selected files") (BCOMPL (FB.COMPILECOMMAND BCOMPL) "Calls BCOMPL on selected files") (COMPILE-FILE (FB.COMPILECOMMAND CL:COMPILE-FILE) "COMPILE-FILE's selected files"))) (|Expunge| FB.EXPUNGECOMMAND "Permanently removes from the file system all files marked for deletion" ) (|Recompute| FB.UPDATECOMMAND "Recomputes set of files satisfying selection pattern" (SUBITEMS ("Same Pattern" FB.UPDATECOMMAND "Recomputes set of files satisfying current pattern" ) ("New Pattern" FB.NEWPATTERNCOMMAND "Prompts for a new selection pattern and updates browser" ) ("New Info" FB.NEWINFOCOMMAND "Change the set of file attributes that are displayed" ) ("Set Depth" FB.DEPTHCOMMAND "Change the depth to which future Recomputes will enumerate the directory (NS servers only)" ) ("Shape to Fit" FB.SHAPECOMMAND "Widen or narrow the browser so that all information is visible" ))) (|Sort| FB.SORTCOMMAND "Sorts all the files in the browser by the attribute of your choice" )))) (VARS FB.VERSION.MENU.ITEMS FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.INFO.MENU.ITEMS FB.DEFAULT.NAME.WIDTH FB.INFO.FIELDS FB.INFOSHADE FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE)) (COMS (* \; "Entries") (COMMANDS "fb") (FNS FB FB.COPYBINARYCOMMAND FB.COPYTEXTCOMMAND FILEBROWSER FB.TABLEBROWSER FB.SELECTEDFILES FB.FETCHFILENAME FB.DIRECTORYP FB.PROMPTWPRINT FB.PROMPTW.FORMAT FB.PROMPTFORINPUT FB.YES-OR-NO-P FB.ALLOW.ABORT \\FB.HARDCOPY.TOFILE.EXTENSION) (* \; "Setup") (FNS FB.STARTUP FB.MAKERIGIDWINDOW) (FNS FB.PRINTFN FB.COPYFN)) (COMS (* \;  "commands and major subfunctions") (FNS FB.MENU.WHENSELECTEDFN FB.COMMANDSELECTEDFN FB.SUBITEMP FB.MAKE.BROWSER.BUSY FB.FINISH.COMMAND FB.HANDLE.ABORT.BUTTON) (FNS FB.DELETECOMMAND FB.DELVERCOMMAND FB.IS.NOT.SUBDIRECTORY.ITEM FB.DELVER.FILES FB.DELETE.FILE) (FNS FB.UNDELETECOMMAND FB.UNDELETEALLCOMMAND FB.UNDELETE.FILE) (FNS FB.COPYCOMMAND FB.RENAMECOMMAND FB.COPY/RENAME.COMMAND FB.COPY/RENAME.ONE FB.COPY/RENAME.MANY FB.MERGE.DIRECTORIES FB.GREATEST.PREFIX FB.MAYBE.INSERT.FILE FB.GET.NEW.FILE.SPEC FB.CANONICAL.DIRECTORY) (FNS FB.HARDCOPYCOMMAND FB.HARDCOPY.TOFILE) (FNS FB.EDITCOMMAND FB.EDITCOMMAND.ONEFILE FB.EDITLISPFILE FB.BROWSECOMMAND) (FNS FB.FASTSEECOMMAND FB.FASTSEE.ONEFILE FB.SEEFULLFN FB.SEEBUTTONFN) (FNS FB.LOADCOMMAND FB.COMPILECOMMAND FB.OPERATE.ON.FILES) (FNS FB.UPDATECOMMAND FB.MAYBE.EXPUNGE FB.UPDATEBROWSERITEMS FB.DATE FB.ADJUST.DATE.WIDTH FB.SET.BROWSER.TITLE FB.MAYBE.WIDEN.NAMES FB.SET.DEFAULT.NAME.WIDTH FB.CREATE.FILEBUCKET FB.CHECK.NAME.LENGTH FB.ADD.FILEGROUP FB.INSERT.DIRECTORY FB.MAKE.SUBDIRECTORY.ITEM FB.ADD.FILE FB.INSERT.FILE FB.ANALYZE.PATTERN FB.CANONICALIZE.PATTERN FB.GETALLFILEINFO) (FNS FB.SORT.VERSIONS FB.DECREASING.VERSION FB.INCREASING.VERSION FB.NAMES.DECREASING.VERSION FB.NAMES.INCREASING.VERSION FB.DECREASING.NUMERIC.ATTR FB.INCREASING.NUMERIC.ATTR FB.ALPHABETIC.ATTR) (FNS FB.SORTCOMMAND FB.INSERT.SUBDIRECTORIES FB.GET.SORT.MENU) (FNS FB.EXPUNGECOMMAND FB.NEWPATTERNCOMMAND FB.NEWINFOCOMMAND FB.DEPTHCOMMAND FB.SHAPECOMMAND FB.REMOVE.FILE FB.COUNT.FILE.CHANGE FB.SETNEWPATTERN FB.GET.NEWPATTERN FB.OPTIONSCOMMAND)) (COMS (* \; "window functions") (FNS FB.INFOMENU.SHADEINITIALSELECTIONS FB.INFO.ITEM.NAMED) (FNS FB.MAKECOUNTERWINDOW FB.COUNTERW.REDISPLAYFN FB.UPDATE.COUNTERS FB.DISPLAY.COUNTERS FB.COUNTER.STRING) (FNS FB.MAKEHEADINGWINDOW FB.HEADINGW.REDISPLAYFN FB.HEADINGW.RESHAPEFN FB.HEADINGW.DISPLAY) (FNS FB.ICONFN FB.INFOMENU.WHENSELECTEDFN FB.CLOSEFN FB.EXPUNGE?.MENU FB.AFTERCLOSEFN FB.CLOSE&EXPUNGE) (FNS FB.HARDCOPY.DIRECTORY FB.HARDCOPY.PRINT.TITLE FB.HARDCOPY.MAXWIDTH)) (DECLARE\: EVAL@COMPILE DONTCOPY (FILES (SOURCE) TABLEBROWSERDECLS) (RECORDS INFOFIELD FBFILEDATA FILEBROWSER) (CONSTANTS FB.MORE.BORDER FB.NULL.VERSION) (MACROS NULL.VERSIONP NULL.DIRECTORYP EQ.DIRECTORYP NULL.FIELDP) (GLOBALVARS FB.ICONFONT FB.BROWSERFONT FB.PROMPTFONT FB.MENUFONT FB.HARDCOPY.FONT FB.HARDCOPY.DIRECTORY.FONT FB.EXPUNGE?MENU FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.MENU.ITEMS FB.DEFAULT.INFO FB.INFOSHADE FB.INFO.MENU.ITEMS FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE DIRCOMMANDS FB.PROMPTLINES FB.INFO.FIELDS |WindowTitleDisplayStream| FB.ICONSPEC FB.DEFAULT.NAME.WIDTH FB.OVERFLOW.MAXABSOLUTE FB.OVERFLOW.MAXFRAC FB.DEFAULT.EDITOR FB.BROWSER.DIRECTORY.FONT ITALICFONT PRINTFILETYPES) (LOCALVARS . T)) (INITRECORDS FILEBROWSER FBFILEDATA) (SYSRECORDS FILEBROWSER FBFILEDATA) (DECLARE\: DONTEVAL@LOAD DOCOPY (P (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T)) (ADDVARS (*ATTACHED-WINDOW-COMMAND-SYNONYMS* (HARDCOPYIMAGEW.TOFILE . HARDCOPYIMAGEW) (HARDCOPYIMAGEW.TOPRINTER . HARDCOPYIMAGEW)) (|BackgroundMenuCommands| ("FileBrowser" '(FILEBROWSER) "Opens a filebrowser window; prompts for pattern" ))) (VARS (|BackgroundMenu|))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA FB) (NLAML) (LAMA FB.PROMPTW.FORMAT FB.PROMPTWPRINT))) )) (DECLARE\: EVAL@COMPILE DONTCOPY (CL:UNLESS (GETP 'EXPORTS.ALL 'FILE) (TERPRI T) (PRIN1 "NOTE: FILEBROWSER requires EXPORTS.ALL" T) (TERPRI T) (TERPRI T)) ) (FILESLOAD ATTACHEDWINDOW ICONW TABLEBROWSER) (* |;;| "Set up for MODERNIZE windows, whether or not MODERNIZE is pre-loaded") (MOVD? 'NILL 'TOTOPW.MODERNIZE) (* |;;| "JDS 11/94 FB.ICONSPEC is now an INITVAR so we can create smaller ones in profiles for, e.g., laptops." ) (RPAQ? FB.EXPUNGE?MENU ) (RPAQ? FB.BROWSERFONT DEFAULTFONT) (RPAQ? FB.BROWSER.DIRECTORY.FONT BOLDFONT) (RPAQ? FB.PROMPTFONT LITTLEFONT) (RPAQ? FB.HARDCOPY.FONT ) (RPAQ? FB.HARDCOPY.DIRECTORY.FONT ) (RPAQ? FB.PROMPTLINES 3) (RPAQ? FB.MENUFONT MENUFONT) (RPAQ? FB.OVERFLOW.MAXABSOLUTE 30) (RPAQ? FB.OVERFLOW.MAXFRAC 0.06) (RPAQ? FB.DEFAULT.EDITOR 'TEDIT) (RPAQ? FB.DEFAULT.INFO '(SIZE CREATIONDATE AUTHOR)) (APPENDTOVAR FONTVARS (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT LITTLEFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT)) (* |;;| "FONTSET fills in the variables in FONTVARS for us, so do it.") (FONTSET (FONTSET)) (ADDTOVAR CACHEDMENUS FB.EXPUNGE?MENU) (RPAQ? FB.MENU.ITEMS '((|Delete| FB.DELETECOMMAND "Marks selected files for deletion. (Use EXPUNGE to remove files from system)" (SUBITEMS ("Delete Selected Files" FB.DELETECOMMAND "Marks the selected files for deletion." ) ("Delete Old Versions" FB.DELVERCOMMAND "Marks for deletion old versions of all files in the browser. You specify how many versions to keep."))) (|Undelete| FB.UNDELETECOMMAND "Removes deletion mark for selected files" (SUBITEMS ("Undelete ALL Files" FB.UNDELETEALLCOMMAND "Removes deletion mark from all files in the browser"))) (|Copy| FB.COPYCOMMAND "Copies selected files (prompts for new file name/directory)" (SUBITEMS ("Copy using TEXT FileType" FB.COPYTEXTCOMMAND "Forces the copying of selected files to be done as TEXT-files") ("Copy using BINARY FileType" FB.COPYBINARYCOMMAND "Forces the copying of selected files to be done as BINARY-files"))) (|Rename| FB.RENAMECOMMAND "Renames (moves) selected files (prompts for new name/directory)" ) (|Hardcopy| FB.HARDCOPYCOMMAND "Produces hardcopy of selected files on your default printer" (SUBITEMS ("To a file" (FB.HARDCOPYCOMMAND FILE) "Generates a hardcopy master of selected file; prompts for filename and format" ) ("To a printer" (FB.HARDCOPYCOMMAND PRINTER) "Sends hardcopy of selected files to a printer of your choosing"))) (|See| (FB.EDITCOMMAND READONLY) "Displays selected files one at a time in a separate window" (SUBITEMS ("Fast SEE Pretty" FB.FASTSEECOMMAND "Views file quickly, uses font information, no scrolling backwards") ("Fast SEE Unformatted" (FB.FASTSEECOMMAND T) "Views file quickly, shows raw characters, no scrolling backwards") ("Scrollable & Pretty" (FB.EDITCOMMAND READONLY) "Views file with font information in a fully scrollable window") ("FileBrowse" FB.BROWSECOMMAND "Recursively call FileBrowser on the selected subdirectory"))) (|Edit| FB.EDITCOMMAND "Calls an editor on the selected files (use submenu to specify editor)" (SUBITEMS ("TEdit" (FB.EDITCOMMAND TEDIT) "Calls TEdit (text editor) on selected files") ("Lisp Edit" (FB.EDITCOMMAND LISP) "Calls Lisp editor on selected files"))) (|Load| FB.LOADCOMMAND "LOADs selected files" (SUBITEMS ("IL:LOAD" FB.LOADCOMMAND "LOADs selected files") ("CL:LOAD" (FB.LOADCOMMAND CL:LOAD) "Performs CL:LOAD on selected files" ) ("Load PROP" (FB.LOADCOMMAND PROP) "Loads the selected files with LDFLG = PROP" ) ("Load SYSLOAD" (FB.LOADCOMMAND SYSLOAD ) "System-loads the files (fast but not undoable)" ) (LOADFROM (FB.LOADCOMMAND LOADFROM) "Performs LOADFROM on selected files" ) (LOADCOMP (FB.LOADCOMMAND LOADCOMP) "Performs LOADCOMP on selected files" ))) (|Compile| FB.COMPILECOMMAND "Compiles selected LISP source files using default compiler" (SUBITEMS (TCOMPL (FB.COMPILECOMMAND TCOMPL) "Calls TCOMPL on selected files") (BCOMPL (FB.COMPILECOMMAND BCOMPL) "Calls BCOMPL on selected files") (COMPILE-FILE (FB.COMPILECOMMAND CL:COMPILE-FILE) "COMPILE-FILE's selected files"))) (|Expunge| FB.EXPUNGECOMMAND "Permanently removes from the file system all files marked for deletion") (|Recompute| FB.UPDATECOMMAND "Recomputes set of files satisfying selection pattern" (SUBITEMS ("Same Pattern" FB.UPDATECOMMAND "Recomputes set of files satisfying current pattern") ("New Pattern" FB.NEWPATTERNCOMMAND "Prompts for a new selection pattern and updates browser") ("New Info" FB.NEWINFOCOMMAND "Change the set of file attributes that are displayed") ("Set Depth" FB.DEPTHCOMMAND "Change the depth to which future Recomputes will enumerate the directory (NS servers only)" ) ("Shape to Fit" FB.SHAPECOMMAND "Widen or narrow the browser so that all information is visible"))) (|Sort| FB.SORTCOMMAND "Sorts all the files in the browser by the attribute of your choice") )) (RPAQQ FB.VERSION.MENU.ITEMS (("1" 1 "Keep only one version of the files") ("2" 2 "Keep two versions of the files") ("3" 3 "Keep three versions of the files") ("4" 4 "Keep four versions of the files") ("Other" :NUMBER "Select number of versions to keep"))) (RPAQQ FB.CLOSE.MENU.ITEMS (("Expunge deleted files" 'EXPUNGE "Erases all files still marked 'deleted'") ("Don't expunge" 'NOEXPUNGE "Proceeds (closes or updates browser) without expunging deleted files. Your deletions are thus ignored."))) (RPAQQ FB.DEPTH.MENU.ITEMS (("Global default" :GLOBAL "Set depth using the global default (FILING.ENUMERATION.DEPTH)" ) ("Infinite" T "Set depth to infinity, i.e., enumerate all levels of directory" ) ("1" 1 "Set depth to 1, i.e., enumerate just the top level of the directory" ) ("2" 2 "Set depth to 2") ("Other" :NUMBER "Set depth to some other finite depth"))) (RPAQQ FB.INFO.MENU.ITEMS ((|Length| LENGTH "Toggles Length display") (|ByteSize| BYTESIZE "Toggles ByteSize display") (|Pages| SIZE "Toggles Pages display") (|Type| TYPE "Toggles Type display") (|Created| CREATIONDATE "Toggles Created display") (|Written| WRITEDATE "Toggles Written display") (|Read| READDATE "Toggles Read display") (|Author| AUTHOR "Toggles Author display"))) (RPAQQ FB.DEFAULT.NAME.WIDTH 140) (RPAQQ FB.INFO.FIELDS ((LENGTH " Length" 70 (FIX 56) "99999999") (SIZE "Pages" 50 (FIX 35) "99999") (BYTESIZE "Byt" 28 (FIX 14) "99") (TYPE "Type" 55 NIL "INTERPRESS") (CREATIONDATE "Created" 170 DATE) (READDATE "Read" 170 DATE) (WRITEDATE "Written" 170 DATE) (AUTHOR "Author" 120))) (RPAQQ FB.INFOSHADE 32800) (RPAQQ FB.ITEMUNSELECTEDSHADE 0) (RPAQQ FB.ITEMSELECTEDSHADE 4672) (* \; "Entries") (DEFCOMMAND "fb" (&REST PAT&PROPS) (APPLY 'FB PAT&PROPS)) (DEFINEQ (FB (NLAMBDA PATTERN (* \; "Edited 26-Feb-88 13:50 by bvm") (* |;;;| "FILEBROWSER entry from top-level exec: FB PATTERN ... PROPS ...") (DESTRUCTURING-BIND (PAT . PROPS) (NLAMBDA.ARGS PATTERN) (LET (OPTIONS) (|for| TAIL |on| PROPS |when| (AND (CL:KEYWORDP (CAR TAIL)) (CDR TAIL)) |do| (* \;  "Interpret keyword tail of attributes as OPTIONS.") (RETURN (SETQ PROPS (LDIFF PROPS (SETQ OPTIONS TAIL))))) (ADD.PROCESS `(,(FUNCTION FILEBROWSER) ',PAT ',PROPS ',OPTIONS) 'NAME 'FB))) NIL)) (FB.COPYBINARYCOMMAND (LAMBDA (BROWSER) (* \;  "Edited 19-Oct-90 18:18 by gadener") (FB.COPY/RENAME.COMMAND BROWSER '|Copy| (CONS (FUNCTION COPYFILE) '((TYPE BINARY)))))) (FB.COPYTEXTCOMMAND (LAMBDA (BROWSER) (* \;  "Edited 19-Oct-90 18:55 by gadener") (FB.COPY/RENAME.COMMAND BROWSER '|Copy| (CONS (FUNCTION COPYFILE) '((TYPE TEXT)))))) (FILEBROWSER (LAMBDA (FILESPEC ATTRIBUTES OPTIONS) (* \; "Edited 30-Aug-94 19:45 by jds") (PROG ((TITLEFONT (DSPFONT NIL |WindowTitleDisplayStream|)) (BROWSERFONTHEIGHT (FONTPROP FB.BROWSERFONT 'HEIGHT)) (MENU-ITEMS FB.MENU.ITEMS) (MENU-TITLE "FB Commands") BROWSER PROMPTWHEIGHT COUNTERHEIGHT BROWSERWINDOW BROWSERWIDTH COMMANDMENU COMMANDMENUWIDTH COMMANDMENUWINDOW HEADINGWINDOW REGION TITLE DEPTH) (COND ((AND (LISTP OPTIONS) (SMALLP (CAR OPTIONS)) (AND (EQLENGTH OPTIONS 4) (EVERY OPTIONS (FUNCTION NUMBERP)))) (* \; "Old style") (SETQ REGION OPTIONS) (SETQ OPTIONS)) (T (|for| TAIL |on| OPTIONS |by| (CDDR TAIL) |do| (PROG ((KEY (CAR TAIL)) (VALUE (CADR TAIL))) RETRY (SELECTQ KEY (:REGION (SETQ REGION VALUE)) (:TITLE (SETQ TITLE VALUE)) ((:MENU-TITLE MENU.TITLE) (SETQ MENU-TITLE VALUE)) ((:MENU-ITEMS MENU.ITEMS) (SETQ MENU-ITEMS VALUE)) (:DEPTH (SETQ DEPTH VALUE)) (|if| (AND (NOT (CL:KEYWORDP KEY)) (SETQ KEY (CL:FIND-SYMBOL (STRING KEY) *KEYWORD-PACKAGE*))) |then| (* \;  "for backward compatibility, coerce other symbols to keywords") (GO RETRY))))))) (SETQ ATTRIBUTES (COND (ATTRIBUTES (* \;  "Caller specifies which attributes to use") (|for| X |in| ATTRIBUTES |collect| (OR (CADR (FB.INFO.ITEM.NAMED X FB.INFO.MENU.ITEMS)) (AND (LISTP DIRCOMMANDS) (OR (|for| PAIR |in| DIRCOMMANDS |when| (AND (LISTP PAIR) (STRING-EQUAL X (CAR PAIR))) |do| (* \;  "Found synonym in dircommands. This also takes care of attribute being in different packages") (RETURN (CDR PAIR))) (PROGN (* \; "Try spelling correction. Wanted to get synonyms this way, but MISSPELLED? seems to be package-sensitive.") (MISSPELLED? X 90 DIRCOMMANDS)))) (\\ILLEGAL.ARG X)))) (T FB.DEFAULT.INFO))) (PROGN (* \;  "Figure out the size of the fixed pieces before prompting for a region") (SETQ COMMANDMENU (|create| MENU MENUFONT _ FB.MENUFONT ITEMS _ MENU-ITEMS CENTERFLG _ T MENUCOLUMNS _ 1 WHENSELECTEDFN _ (FUNCTION FB.MENU.WHENSELECTEDFN) TITLE _ MENU-TITLE)) (SETQ COMMANDMENUWIDTH (|fetch| (MENU IMAGEWIDTH) |of| COMMANDMENU)) (SETQ PROMPTWHEIGHT (HEIGHTIFWINDOW (TIMES FB.PROMPTLINES (FONTPROP FB.PROMPTFONT 'HEIGHT)))) (SETQ COUNTERHEIGHT (HEIGHTIFWINDOW (FONTPROP TITLEFONT 'HEIGHT) T))) (PROGN (* |;;| "First make the main window, carved out of the space in REGION leftover after the fixed parts are accounted for") (COND ((NOT REGION) (PROMPTPRINT (CL:FORMAT NIL "Specify region for FileBrowser~@[ on ~A~]" FILESPEC )) (SETQ REGION (GETREGION (PROGN (* \;  "Min width is menu plus enough space to print a name") (+ COMMANDMENUWIDTH FB.DEFAULT.NAME.WIDTH TB.LEFT.MARGIN)) (PROGN (* \;  "Min height is prompt window plus counter window plus heading plus 5 lines of files") (+ PROMPTWHEIGHT COUNTERHEIGHT (TIMES 6 BROWSERFONTHEIGHT ))))) (CLRPROMPT))) (|if| (AND (NULL FILESPEC) (NOT (TTY.PROCESSP))) |then| (* \;  "Grab the tty now, so that user can start typing ahead") (TTY.PROCESS (THIS.PROCESS)) (ALLOW.BUTTON.EVENTS)) (SETQ BROWSERWINDOW (CREATEW (|create| REGION |using| REGION WIDTH _ (SETQ BROWSERWIDTH (- (|fetch| (REGION WIDTH) |of| REGION) COMMANDMENUWIDTH)) HEIGHT _ (- (|fetch| (REGION HEIGHT) |of| REGION) (+ COUNTERHEIGHT PROMPTWHEIGHT BROWSERFONTHEIGHT))))) (DSPFONT FB.BROWSERFONT BROWSERWINDOW) (WINDOWPROP BROWSERWINDOW 'FILEBROWSER (SETQ BROWSER (|create| FILEBROWSER BROWSERWINDOW _ BROWSERWINDOW BROWSERFONT _ FB.BROWSERFONT OVERFLOWSPACING _ (TIMES 3 (CHARWIDTH (CHARCODE \a) FB.BROWSERFONT)) SORTBY _ (FUNCTION FB.NAMES.DECREASING.VERSION) FIXEDTITLE _ TITLE INFOMENUCHOICES _ ATTRIBUTES FBLOCK _ (CREATE.MONITORLOCK) FBDEPTH _ DEPTH)))) (PROGN (* \;  "Atop this sits the black heading window, with labels for each column in browser") (|replace| (FILEBROWSER HEADINGWINDOW) |of| BROWSER |with| (SETQ HEADINGWINDOW (FB.MAKEHEADINGWINDOW BROWSERWINDOW BROWSERWIDTH BROWSERFONTHEIGHT FB.BROWSERFONT)))) (PROGN (* \;  "Atop that is the counter window, whose title contains the file pattern") (FB.MAKECOUNTERWINDOW BROWSERWINDOW TITLEFONT BROWSERWIDTH COUNTERHEIGHT TITLE)) (PROGN (* \;  "Main command menu sits on the right side") (SETQ COMMANDMENUWINDOW (MENUWINDOW COMMANDMENU)) (ATTACHWINDOW COMMANDMENUWINDOW BROWSERWINDOW 'RIGHT 'TOP)) (PROGN (* \;  "Finally the prompt window atop it all") (|replace| (FILEBROWSER PROMPTWINDOW) |of| BROWSER |with| (FB.MAKERIGIDWINDOW (GETPROMPTWINDOW BROWSERWINDOW FB.PROMPTLINES FB.PROMPTFONT)))) (PROGN (* \;  "Now make them all open. For some reason, attaching the menu didn't open it") (TOTOPW BROWSERWINDOW)) (|replace| (FILEBROWSER ABORTWINDOW) |of| BROWSER |with| (CONS (MENUWINDOW (|create| MENU ITEMS _ '(("--Abort--" NIL "Abort the current FileBrowser operation" )) CENTERFLG _ T MENUOUTLINESIZE _ 2 MENUFONT _ (FONTCOPY FB.MENUFONT 'WEIGHT 'BOLD) WHENSELECTEDFN _ (FUNCTION FB.HANDLE.ABORT.BUTTON))) COMMANDMENUWINDOW)) (|for| W |in| (LIST COMMANDMENUWINDOW (CAR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER)) (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER) (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER)) |bind| OLDCOMS |when| (LISTP (SETQ OLDCOMS (WINDOWPROP W 'PASSTOMAINCOMS))) |do| (* \;  "Make all these subwindows pass hardcopy on to the main window") (WINDOWPROP W 'PASSTOMAINCOMS (UNION '(HARDCOPYIMAGEW) OLDCOMS))) (|replace| (FILEBROWSER TABLEBROWSER) |of| BROWSER |with| (TB.MAKE.BROWSER NIL BROWSERWINDOW (LIST 'PRINTFN (FUNCTION FB.PRINTFN) 'COPYFN (FUNCTION FB.COPYFN) 'USERDATA BROWSER 'CLOSEFN (FUNCTION FB.CLOSEFN) 'AFTERCLOSEFN (FUNCTION FB.AFTERCLOSEFN) 'HEADINGWINDOW HEADINGWINDOW))) (WINDOWPROP BROWSERWINDOW 'HARDCOPYFN (FUNCTION FB.HARDCOPY.DIRECTORY)) (WINDOWPROP BROWSERWINDOW 'ICONFN (FUNCTION FB.ICONFN)) (|if| (SETQ FILESPEC (|if| FILESPEC |then| (DIRECTORY.FILL.PATTERN FILESPEC) |else| (FB.STARTUP BROWSER COMMANDMENU (FUNCTION FB.GET.NEWPATTERN)))) |then| (* \;  "Have a pattern to work with. Now enumerate it in a new process.") (FB.SETNEWPATTERN BROWSER FILESPEC) (ADD.PROCESS `(,(FUNCTION FB.STARTUP) ',BROWSER ',COMMANDMENU ',(FUNCTION FB.UPDATEBROWSERITEMS)) 'NAME '|FB-Update| 'BEFOREEXIT 'DON\'T)) (RETURN BROWSERWINDOW)))) (FB.TABLEBROWSER (LAMBDA (BROWSER) (* \; "Edited 4-Feb-88 23:13 by bvm:") (|ffetch| (FILEBROWSER TABLEBROWSER) |of| (\\DTEST BROWSER 'FILEBROWSER)))) (FB.SELECTEDFILES (LAMBDA (BROWSER NOERRORFLG) (* \; "Edited 29-Jan-88 12:38 by bvm") (* |;;| "User entry to get the set of selected files, as tableitems, from a filebrowser. If NOERRORFLG is NIL, will print a message if no files are selected.") (COND ((TB.COLLECT.ITEMS (|ffetch| (FILEBROWSER TABLEBROWSER) |of| (\\DTEST BROWSER 'FILEBROWSER)) 'SELECTED)) ((NOT NOERRORFLG) (FB.PROMPTWPRINT BROWSER T "No files are selected") NIL)))) (FB.FETCHFILENAME (LAMBDA (ITEM) (* \; "Edited 29-Jan-88 12:37 by bvm") (* |;;| "User entry to get filename from a browser tableitem.") (|fetch| (FBFILEDATA FILENAME) |of| (|ffetch| TIDATA |of| (\\DTEST ITEM 'TABLEITEM))))) (FB.DIRECTORYP (LAMBDA (FILE) (* \; "Edited 20-Feb-2021 20:05 by rmk:") (* |;;| "Does FILE denote a directory?") (CL:WHEN (TYPE? TABLEITEM FILE) (SETQ FILE (FETCH TIDATA OF FILE))) (|fetch| (FBFILEDATA DIRECTORYFILEP) |of| FILE))) (FB.PROMPTWPRINT (LAMBDA U (* \; "Edited 4-Feb-88 23:08 by bvm:") (COND ((< U 2) (ERROR "not enough args to PROMPTWPRINT")) (T (LET ((WINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST (ARG U 1) 'FILEBROWSER))) THING) (* \;  "CAR is window, CDR is height in lines") (|for| ITEM |from| 2 |to| U |do| (SELECTQ (SETQ THING (ARG U ITEM)) (T (TERPRI WINDOW)) (CLEAR (CLEARW WINDOW)) (FRESH (FRESHLINE WINDOW)) (PRIN1 THING WINDOW)))))))) (FB.PROMPTW.FORMAT (CL:LAMBDA (BROWSER FORMAT-STRING &REST ARGS) (* \; "Edited 4-Feb-88 23:15 by bvm:") (* |;;| "Outputs to FOLDER's prompt window using FORMAT.") (LET ((*PRINT-CASE* :UPCASE) (*PRINT-BASE* 10) (WINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST BROWSER 'FILEBROWSER)))) (* |;;| "*PRINT-CASE* is bound so symbols get printed in \"expected\" case. *PRINT-BASE* is 10 for benefit of printing numbers in the non-format case.") (CL:APPLY (FUNCTION CL:FORMAT) WINDOW FORMAT-STRING ARGS)))) (FB.PROMPTFORINPUT (LAMBDA (PROMPT DEFAULT BROWSER ABORTFLG DONTCLEAR) (* \; "Edited 22-Nov-88 15:33 by bvm") (* |;;;| "Prompt for input for browser BROWSER with question PROMPT offering default answer DEFAULT. If ABORTFLG is true and response is NIL, prints '... aborted'") (LET* ((PWINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST BROWSER 'FILEBROWSER))) (PROMPTWIDTH (STRINGWIDTH PROMPT PWINDOW)) (WINDOWWIDTH (WINDOWPROP PWINDOW 'WIDTH)) RESULT) (COND (DONTCLEAR (FRESHLINE PWINDOW)) (T (CLEARW PWINDOW))) (COND ((> (+ PROMPTWIDTH (STRINGWIDTH (OR DEFAULT "XXX") PWINDOW)) WINDOWWIDTH) (* |;;| "Prompt plus default response will overflow the width of the window, so be a nice guy and break it up") (|for| I |from| (- (NCHARS PROMPT) 4) |to| 10 |by| -1 |bind| (EXCESSWIDTH _ (- PROMPTWIDTH WINDOWWIDTH)) |when| (AND (EQ (NTHCHARCODE PROMPT I) (CHARCODE SPACE)) (> (STRINGWIDTH (SUBSTRING PROMPT I) PWINDOW) EXCESSWIDTH)) |do| (RETURN (SETQ PROMPT (CONCAT (SUBSTRING PROMPT 1 (SUB1 I)) (CONSTANT (CHARACTER (CHARCODE CR))) (SUBSTRING PROMPT (ADD1 I)))))))) (SETQ RESULT (CAR (NLSETQ (TTYINPROMPTFORWORD PROMPT DEFAULT NIL PWINDOW NIL 'TTY (CHARCODE (CR)))))) (WINDOWPROP PWINDOW 'PROCESS NIL) (* \;  "Get rid of process from prompt window") (COND ((AND (NULL RESULT) ABORTFLG) (PRINTOUT PWINDOW "... aborted"))) (TERPRI PWINDOW) RESULT))) (FB.YES-OR-NO-P (LAMBDA (PROMPT FBROWSER DEFAULT) (* \; "Edited 22-Nov-88 15:30 by bvm") (* |;;|  "Return Y, N or NIL, indicating whether response to question is Yes, No or some kind of abort") (LET ((ANSWER (FB.PROMPTFORINPUT PROMPT (SELECTQ DEFAULT (Y "Yes") (N "No") NIL) FBROWSER T T))) (COND ((NULL ANSWER) (* \; "Aborted") NIL) ((OR (STRING-EQUAL ANSWER "YES") (STRING-EQUAL ANSWER "Y")) 'Y) ((OR (STRING-EQUAL ANSWER "NO") (STRING-EQUAL ANSWER "N")) 'N) (T (FB.PROMPTWPRINT FBROWSER "?? ...Aborted.") (* \; "Confused somehow") NIL))))) (FB.ALLOW.ABORT (LAMBDA (BROWSER) (* \; "Edited 4-Feb-88 23:11 by bvm:") (* |;;| "Arranges that this browser have an abort button armed. Must be called underneath a FileBrowser command, so that the cleanup in fb.make.browser.busy is enabled.") (|freplace| (FILEBROWSER UPDATEPROC) |of| (\\DTEST BROWSER 'FILEBROWSER) |with| (THIS.PROCESS)) (LET ((W (|ffetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER))) (|if| (NOT (OPENWP (CAR W))) |then| (ATTACHWINDOW (CAR W) (CDR W) 'BOTTOM) (* \;  "And repaint it in case it was used last time") (REDISPLAYW (CAR W)))))) (\\FB.HARDCOPY.TOFILE.EXTENSION (LAMBDA NIL (* \;  "Edited 25-Feb-91 15:15 by gadener") (LET ((TYPE (PRINTERTYPE))) (CASE TYPE (INTERPRESS 'IP) (POSTSCRIPT 'PS) (DEFAULT TYPE))))) ) (* \; "Setup") (DEFINEQ (FB.STARTUP (LAMBDA (BROWSER COMMANDMENU FN) (* \; "Edited 21-Jan-88 17:53 by bvm") (* |;;| "Apply FN to browser with Recompute grayed out.") (RESETLST (FB.MAKE.BROWSER.BUSY BROWSER (FASSOC '|Recompute| (|fetch| (MENU ITEMS) |of| COMMANDMENU) ) COMMANDMENU) (CL:FUNCALL FN BROWSER)))) (FB.MAKERIGIDWINDOW (LAMBDA (WINDOW) (* |bvm:| "22-Jul-85 16:14") (* |;;;| "make the argument window immutable w/r/to attachedwindow package") (LET ((HEIGHT (|fetch| (REGION HEIGHT) |of| (WINDOWPROP WINDOW 'REGION)))) (WINDOWPROP WINDOW 'MINSIZE (CONS 0 HEIGHT)) (WINDOWPROP WINDOW 'MAXSIZE (CONS SCREENWIDTH HEIGHT)) WINDOW))) ) (DEFINEQ (FB.PRINTFN (LAMBDA (TBROWSER ITEM WINDOW) (* \; "Edited 30-Aug-94 19:12 by jds") (LET ((FBROWSER (TB.USERDATA TBROWSER)) (FDATA (|fetch| TIDATA |of| ITEM)) (STREAM (WINDOWPROP WINDOW 'DSP)) NEXTPOS INFO OLDFONT) (COND ((|fetch| (FBFILEDATA DIRECTORYP) |of| FDATA) (PRIN3 " " STREAM) (|if| FB.BROWSER.DIRECTORY.FONT |then| (SETQ OLDFONT (DSPFONT FB.BROWSER.DIRECTORY.FONT STREAM))))) (LET* ((FILENAME (|fetch| (FBFILEDATA FILENAME) |of| FDATA)) (OFF (|ffetch| (STRINGP OFFST) |of| FILENAME)) (BASE (|ffetch| (STRINGP BASE) |of| FILENAME)) (FATP (|ffetch| (STRINGP FATSTRINGP) |of| FILENAME)) (END (+ OFF (|ffetch| (STRINGP LENGTH) |of| FILENAME))) C) (* |;;| "This loop is a performance optimization so I don't have to cons up a substring in the display loop. This is essentially (for c instring (fetch (fbfiledata filename) of fdata) do (\\outchar stream c)), except that I want to start at STARTOFPNAME rather than 1.") (* |;;| "Slow version: (prin3 (fetch (fbfiledata printname) of fdata) stream), except it doesn't let me intercept cr's.") (|add| OFF (- (|fetch| (FBFILEDATA STARTOFPNAME) |of| FDATA) 2)) (* \; "Skip to start of name to print") (|while| (< (|add| OFF 1) END) |do| (SETQ C (COND (FATP (\\GETBASEFAT BASE OFF)) (T (\\GETBASETHIN BASE OFF)))) (\\OUTCHAR STREAM (|if| (EQ C (CHARCODE CR)) |then| (* \; "make it a blotch instead of new line #o377 is in char set 0, but is an illegal char, so can't have a glyph") 255 |else| C)))) (SETQ NEXTPOS (|fetch| (FILEBROWSER INFOSTART) |of| FBROWSER)) (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |as| INFO |in| (|fetch| (FBFILEDATA FILEINFO) |of| FDATA) |bind| (FONT _ (|fetch| (FILEBROWSER BROWSERFONT) |of| FBROWSER)) FORMAT ACTUALNEXT XPOS |do| (COND (INFO (* \;  "Make sure there's always some space before next item") (PRIN3 " " STREAM))) (SETQ XPOS (DSPXPOSITION NIL STREAM)) (SETQ FORMAT (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) (SETQ ACTUALNEXT (COND ((AND (LISTP FORMAT) (FIXP INFO)) (* \;  "Get numbers to line up right justified") (IMAX (- (+ NEXTPOS (CADR FORMAT)) (STRINGWIDTH INFO FONT)) XPOS)) (T (* \;  "All other fields are left-justified") NEXTPOS))) (COND ((< XPOS ACTUALNEXT) (* \;  "Clear any previous junk between last position and start of field") (|if| (AND INFO (EQ FORMAT 'DATE) (EQ (CHCON1 INFO) (CHARCODE SPACE))) |then| (* \; "Small nicety for variable-width font: account for the difference between a space and a digit, so that dates line up a little better") (|add| ACTUALNEXT (- (CHARWIDTH (CHARCODE 9) FONT) (CHARWIDTH (CHARCODE SPACE) FONT)))) (TB.CLEAR.LINE TBROWSER ITEM XPOS (- ACTUALNEXT XPOS)) (DSPXPOSITION ACTUALNEXT STREAM))) (COND (INFO (PRIN3 INFO STREAM))) (|add| NEXTPOS (|fetch| (INFOFIELD INFOWIDTH) |of| SPEC))) (TB.CLEAR.LINE TBROWSER ITEM (DSPXPOSITION NIL STREAM)) (AND OLDFONT (DSPFONT OLDFONT STREAM))))) (FB.COPYFN (LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (BKSYSBUF (|fetch| (FBFILEDATA FILENAME) |of| (|fetch| TIDATA |of| ITEM))))) ) (* \; "commands and major subfunctions") (DEFINEQ (FB.MENU.WHENSELECTEDFN (LAMBDA (ITEM MENU KEY) (* \; "Edited 21-Jan-88 11:40 by bvm") (ADD.PROCESS `(,(FUNCTION FB.COMMANDSELECTEDFN) ',ITEM ',MENU ',KEY) 'NAME (PACK* 'FB- (CAR ITEM)) 'BEFOREEXIT 'DON\'T))) (FB.COMMANDSELECTEDFN (LAMBDA (ITEM MENU KEY) (* \; "Edited 12-Jan-87 12:57 by bvm:") (RESETLST (LET* ((REALITEM ITEM) (WINDOW (WINDOWPROP (WFROMMENU MENU) 'MAINWINDOW)) (FBROWSER (WINDOWPROP WINDOW 'FILEBROWSER))) (COND ((NOT (MEMBER ITEM (|fetch| (MENU ITEMS) |of| MENU))) (* \; "A subitem -- fetch main item") (SETQ ITEM (|for| I |in| (|fetch| (MENU ITEMS) |of| MENU) |thereis| (FB.SUBITEMP ITEM I))))) (COND ((FB.MAKE.BROWSER.BUSY FBROWSER ITEM MENU) (LET ((FN (CADR REALITEM)) (PWINDOW (|fetch| (FILEBROWSER PROMPTWINDOW) |of| FBROWSER)) EXTRA) (COND ((OPENWP PWINDOW) (CLEARW PWINDOW))) (COND ((LISTP FN) (SETQ EXTRA (CADR FN)) (SETQ FN (CAR FN)))) (CL:FUNCALL FN FBROWSER KEY REALITEM MENU EXTRA))) (T (* \; "Used to be (FB.PROMPTWPRINT WINDOW 'This filebrowser is busy') but that trashes the prompt window") (FLASHWINDOW WINDOW))))))) (FB.SUBITEMP (LAMBDA (SUBITEM ITEM) (* |bvm:| "22-Jul-85 15:08") (* |;;;| "True if SUBITEM appears among the subitems of ITEM or descendents") (LET ((SUB (CADDDR ITEM))) (AND SUB (EQ (CAR (LISTP SUB)) 'SUBITEMS) (OR (MEMBER SUBITEM SUB) (|for| I |in| (CDR SUB) |thereis| (FB.SUBITEMP SUBITEM I))))))) (FB.MAKE.BROWSER.BUSY (LAMBDA (BROWSER ITEM MENU DONTWAIT) (* \; "Edited 27-Feb-2021 19:21 by rmk:") (* \; "Edited 1-Feb-88 16:43 by bvm:") (* |;;;| "Makes browser 'busy' doing ITEM of MENU. Must be called under RESETLST") (COND ((OBTAIN.MONITORLOCK (|fetch| (FILEBROWSER FBLOCK) |of| BROWSER) DONTWAIT T) (RESETSAVE NIL (LIST (FUNCTION FB.FINISH.COMMAND) BROWSER ITEM MENU)) (|if| ITEM |then| (SHADEITEM ITEM MENU FB.ITEMSELECTEDSHADE) (PUTMENUPROP MENU 'ITEMSHADE (CONS ITEM FB.ITEMSELECTEDSHADE))) T)))) (FB.FINISH.COMMAND (LAMBDA (BROWSER ITEM MENU) (* \; "Edited 27-Feb-2021 19:52 by rmk:") (* \; "Edited 1-Feb-88 16:34 by bvm:") (* |;;| "Cleanup after generic command on BROWSER. ITEM and MENU (optional) specify the shaded item. This is called under a RESETLST by anyone calling FB.MAKE.BROWSER.BUSY, but needs to be called explicitly by anyone who closes/shrinks the window before that cleanup would happen.") (|replace| (FILEBROWSER UPDATEPROC) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER ABORTING) |of| BROWSER |with| NIL) (* |;;| "RMK: Don't reshade the item if it isn't needed. This will prevent the FB window from popping on top of any windows that the menu command created (SEE, EDIT), if they clear it before they open their windows.") (LET ((W (CAR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER))) M) (|if| (OPENWP W) |then| (* \;  "Take down the abort button if there was one") (DETACHWINDOW W) (SHADEITEM (CAR (|fetch| (MENU ITEMS) |of| (SETQ M (CAR (WINDOWPROP W 'MENU))))) M FB.ITEMUNSELECTEDSHADE) (CLOSEW W))) (|if| (AND ITEM (EQ ITEM (CAR (GETMENUPROP MENU 'ITEMSHADE))) (NEQ FB.ITEMUNSELECTEDSHADE (CDR (GETMENUPROP MENU 'ITEMSHADE)))) |then| (SHADEITEM ITEM MENU FB.ITEMUNSELECTEDSHADE) (PUTMENUPROP MENU 'FB.ITEMUNSELECTEDSHADE NIL)) (COND (RESETSTATE (FB.PROMPTWPRINT BROWSER "...command aborted."))))) (FB.HANDLE.ABORT.BUTTON (LAMBDA (ITEM MENU) (* \; "Edited 27-Jan-88 23:38 by bvm") (* |;;| "Called when the ABORT button on a Filebrowser is pressed.") (LET ((BROWSER (WINDOWPROP (MAINWINDOW (WFROMMENU MENU) T) 'FILEBROWSER)) PROC) (|if| (AND BROWSER (SETQ PROC (|fetch| (FILEBROWSER UPDATEPROC) |of| BROWSER )) (NOT (|fetch| (FILEBROWSER ABORTING) |of| BROWSER))) |then| (* \;  "We're connected to a browser, there's a process running, and it's not already aborting") (SHADEITEM ITEM MENU FB.ITEMSELECTEDSHADE) (|replace| (FILEBROWSER ABORTING) |of| BROWSER |with| T) (DEL.PROCESS PROC))))) ) (DEFINEQ (FB.DELETECOMMAND (LAMBDA (BROWSER) (* |bvm:| "12-Sep-85 15:44") (TB.MAP.SELECTED.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.DELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER))) (FB.DELVERCOMMAND (LAMBDA (FBROWSER) (* \;  "Edited 15-Feb-91 17:19 by gadener") (LET (NVERSIONS TBROWSER NDELETED FILES) (|if| (EQ (SETQ NVERSIONS (MENU (|create| MENU TITLE _ "Versions to keep ?" ITEMS _ FB.VERSION.MENU.ITEMS CENTERFLG _ T))) :NUMBER) |then| (FB.ALLOW.ABORT FBROWSER) (SETQ NVERSIONS (RNUMBER "Number of versions to keep ?" NIL NIL NIL T NIL T))) (COND ((NOT NVERSIONS) NIL) ((NOT (FIXP (SETQ NVERSIONS (MKATOM NVERSIONS)))) (FB.PROMPTW.FORMAT FBROWSER "~%?? ~A not an integer." NVERSIONS)) ((EQ NVERSIONS 0) NIL) (T (SETQ FILES (TB.COLLECT.ITEMS (SETQ TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER)) (FUNCTION (LAMBDA (BROWSER ITEM) (* \; "Collect everything that is not a directory item and that has an actual version (to avoid unix lossage)") (AND (NOT (|fetch| TIUNSELECTABLE |of| ITEM)) (NOT (NULL.VERSIONP (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| ITEM)) ))))))) (SETQ NDELETED (FB.DELVER.FILES TBROWSER (SELECTQ (|fetch| (FILEBROWSER SORTBY) |of| FBROWSER ) (FB.NAMES.DECREASING.VERSION (* \; "Just right") FILES) (FB.NAMES.INCREASING.VERSION (* \; "Close, but no cigar") (FB.SORT.VERSIONS FILES (FUNCTION FB.DECREASING.VERSION))) (SORT FILES (FUNCTION FB.NAMES.DECREASING.VERSION))) NVERSIONS)) (FB.UPDATE.COUNTERS FBROWSER 'DELETED) (FB.PROMPTW.FORMAT FBROWSER "~%Done, ~D files marked for deletion." NDELETED)))))) (FB.IS.NOT.SUBDIRECTORY.ITEM (LAMBDA (BROWSER ITEM) (* |bvm:| "13-Oct-85 16:51") (NOT (|fetch| TIUNSELECTABLE |of| ITEM)))) (FB.DELVER.FILES (LAMBDA (TBROWSER FILES NVERSIONS) (* |bvm:| "15-Oct-85 00:20") (|for| FILE |in| FILES |bind| (\#DELETED _ 0) (\#SEENSOFAR _ 0) THISNAME LASTNAME |do| (* \;  "Files now all lined up, decreasing version. Just pass by NVERSIONS of each file") (COND ((STRING-EQUAL (SETQ THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| FILE))) LASTNAME) (COND ((GREATERP (|add| \#SEENSOFAR 1) NVERSIONS) (COND ((FB.DELETE.FILE TBROWSER FILE) (|add| \#DELETED 1)))))) (T (SETQ LASTNAME THISNAME) (SETQ \#SEENSOFAR 1))) |finally| (RETURN \#DELETED)))) (FB.DELETE.FILE (LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (COND ((NOT (|fetch| TIDELETED |of| ITEM)) (LET ((FBROWSER (TB.USERDATA TBROWSER)) SIZE) (TB.DELETE.ITEM TBROWSER ITEM) (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) 1) (COND ((SETQ SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) SIZE))) T))))) ) (DEFINEQ (FB.UNDELETECOMMAND (LAMBDA (BROWSER) (* |bvm:| "12-Sep-85 15:44") (TB.MAP.SELECTED.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.UNDELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER))) (FB.UNDELETEALLCOMMAND (LAMBDA (BROWSER) (* |bvm:| "18-Sep-85 12:20") (TB.MAP.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.UNDELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER))) (FB.UNDELETE.FILE (LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (COND ((|fetch| TIDELETED |of| ITEM) (LET ((FBROWSER (TB.USERDATA TBROWSER)) SIZE) (TB.UNDELETE.ITEM TBROWSER ITEM) (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) -1) (COND ((SETQ SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) (IMINUS SIZE))))))))) ) (DEFINEQ (FB.COPYCOMMAND (LAMBDA (BROWSER) (* \;  "Edited 19-Oct-90 17:44 by gadener") (FB.COPY/RENAME.COMMAND BROWSER '|Copy| (CONS (FUNCTION COPYFILE))))) (FB.RENAMECOMMAND (LAMBDA (BROWSER) (* \;  "Edited 19-Oct-90 18:57 by gadener") (FB.COPY/RENAME.COMMAND BROWSER '|Rename| (CONS (FUNCTION RENAMEFILE))))) (FB.COPY/RENAME.COMMAND (LAMBDA (FBROWSER CMD MOVEFN) (* \; "Edited 28-Jan-88 00:27 by bvm") (LET ((*UPPER-CASE-FILE-NAMES* NIL) (FILELIST (FB.SELECTEDFILES FBROWSER))) (|if| FILELIST |then| (FB.ALLOW.ABORT FBROWSER) (COND ((CDR FILELIST) (FB.COPY/RENAME.MANY FBROWSER FILELIST CMD MOVEFN)) (T (* \; "Just one file") (LET* ((OLDNAME (FB.FETCHFILENAME (CAR FILELIST))) (NEWNAME (FB.GET.NEW.FILE.SPEC OLDNAME FBROWSER CMD))) (COND (NEWNAME (FB.COPY/RENAME.ONE FBROWSER (CAR FILELIST) OLDNAME NEWNAME CMD MOVEFN)))))))))) (FB.COPY/RENAME.ONE (LAMBDA (FBROWSER ITEM OLDNAME NEWNAME CMD MOVEFN) (* \;  "Edited 19-Oct-90 17:50 by gadener") (* |;;;| "Copies or renames a single file ITEM from OLDNAME to NEWNAME and updates browser accordingly") (CL:MULTIPLE-VALUE-BIND (ACTUALNEWNAME CONDITION) (IGNORE-ERRORS (CL:FUNCALL (CAR MOVEFN) OLDNAME NEWNAME (CDR MOVEFN))) (COND (ACTUALNEWNAME (FB.PROMPTW.FORMAT FBROWSER "~%~A ~Aed to ~A" OLDNAME (SELECTQ CMD (|Copy| "copi") (|Rename| "renam") (SHOULDNT)) ACTUALNEWNAME) (LET ((CHANGETYPE (COND ((EQ CMD '|Rename|) (FB.REMOVE.FILE (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER) FBROWSER ITEM) (COND ((|fetch| TIDELETED |of| ITEM) 'BOTH) (T 'TOTAL)))))) (COND ((FB.MAYBE.INSERT.FILE FBROWSER ACTUALNEWNAME ITEM CMD) (* \;  "ACTUALNEWNAME belongs in this browser, so TOTAL may have changed") (OR CHANGETYPE (SETQ CHANGETYPE 'TOTAL)))) (COND (CHANGETYPE (FB.UPDATE.COUNTERS FBROWSER CHANGETYPE))))) (T (FB.PROMPTW.FORMAT FBROWSER "~%Could not ~(~A~) ~A ~A ~A" CMD OLDNAME (|if| CONDITION |then| "because" |else| "to") (OR CONDITION NEWNAME))))))) (FB.COPY/RENAME.MANY (LAMBDA (FBROWSER FILELIST CMD MOVEFN) (* \; "Edited 22-Jan-94 20:24 by ") (PROG (PREFIX OLDNAME FIELDS SUBDIR FIRSTDATA RETAIN HOST DIR DEVICE) (COND ((NULL (SETQ PREFIX (FB.PROMPTFORINPUT (CONCAT CMD " " (LENGTH FILELIST) " files to which directory? ") (OR (|fetch| (FILEBROWSER DEFAULTDIR) |of| FBROWSER) (DIRECTORYNAME T)) FBROWSER T))) (* \; "Aborted") ) ((STRPOS "*" PREFIX) (FB.PROMPTWPRINT FBROWSER "Sorry, patterns not supported")) ((AND (OR (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING PREFIX)) 'HOST) (LISTGET FIELDS 'DIRECTORY) (LISTGET FIELDS 'DEVICE)) (OR (LISTGET FIELDS 'NAME) (LISTGET FIELDS 'EXTENSION) (LISTGET FIELDS 'VERSION))) (* \;  "Not a pure directory specification, and not just a simple directory name") (FB.PROMPTWPRINT FBROWSER "Not a well-formed directory specification.")) ((SETQ PREFIX (FB.CANONICAL.DIRECTORY (\\ADD.CONNECTED.DIR PREFIX) FBROWSER CMD)) (SETQ HOST (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING PREFIX)) 'HOST)) (SETQ DIR (OR (LISTGET FIELDS 'DIRECTORY) (LISTGET FIELDS 'RELATIVEDIRECTORY))) (SETQ DEVICE (LISTGET FIELDS 'DEVICE)) (|replace| (FILEBROWSER DEFAULTDIR) |of| FBROWSER |with| PREFIX) (* |;;| "First scan to see if the files are in multiple subdirectories, since then it's unclear how the new files should be named.") (SETQ FIRSTDATA (|fetch| TIDATA |of| (CAR FILELIST))) (COND ((|for| ITEM |in| (CDR FILELIST) |thereis| (NOT (EQ.DIRECTORYP FIRSTDATA (|fetch| TIDATA |of| ITEM))) ) (SETQ SUBDIR (|fetch| (FBFILEDATA SUBDIRECTORY) |of| FIRSTDATA)) (FB.PROMPTWPRINT FBROWSER "Selected files are in multiple subdirectories") (SETQ RETAIN (SELECTQ (FB.YES-OR-NO-P (CONCAT "Retain subdirectory names below level of " (|for| ITEM |in| (CDR FILELIST) |repeatwhile| (SETQ SUBDIR (FB.GREATEST.PREFIX SUBDIR (|fetch| (FBFILEDATA FILENAME) |of| (|fetch| TIDATA |of| ITEM)))) |finally| (RETURN (OR SUBDIR (SETQ SUBDIR (SUBSTRING (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) 1 (SUB1 (|fetch| (FILEBROWSER NAMESTART) |of| FBROWSER))))))) "?") FBROWSER 'Y) (NIL (* \; "Aborted") (RETURN)) (Y (SETQ SUBDIR (ADD1 (NCHARS SUBDIR))) (* \; "First character that changes") T) NIL)))) (* |;;| "Now make sure the files are sorted by increasing version, so that multiple versions get copied in the right order") (SELECTQ (|fetch| (FILEBROWSER SORTBY) |of| FBROWSER) (FB.NAMES.INCREASING.VERSION (* \; "Okay") ) (FB.NAMES.DECREASING.VERSION (SETQ FILELIST (FB.SORT.VERSIONS FILELIST (FUNCTION FB.INCREASING.VERSION) ))) (SORT FILELIST (FUNCTION FB.NAMES.INCREASING.VERSION))) (|for| ITEM |in| FILELIST |do| (FB.COPY/RENAME.ONE FBROWSER ITEM (SETQ OLDNAME (FB.FETCHFILENAME ITEM)) (PACKFILENAME.STRING 'HOST HOST 'DEVICE DEVICE 'DIRECTORY (|if| (NOT RETAIN) |then| DIR |else| (* \;  "Merge destination directory with subdirectory of name between common prefix and root") (FB.MERGE.DIRECTORIES DIR (SUBSTRING OLDNAME SUBDIR (SUB1 (|fetch| (FBFILEDATA STARTOFNAME) |of| (|fetch| TIDATA |of| ITEM)))))) 'VERSION NIL 'BODY OLDNAME) CMD MOVEFN))))))) (FB.MERGE.DIRECTORIES (LAMBDA (PREFIX RETAIN) (* \; "Edited 22-Jun-90 11:29 by nm") (COND (PREFIX (|if| RETAIN |then| (CONCAT PREFIX (CL:SECOND \\FILENAME.SYNTAX) RETAIN) |else| PREFIX)) (T (|if| RETAIN |then| RETAIN |else| NIL))))) (FB.GREATEST.PREFIX (LAMBDA (DIR FILENAME) (* \; "Edited 25-Jan-88 16:37 by bvm") (* |;;;| "Greatest common directory prefix of DIR and FILENAME") (AND DIR FILENAME (COND ((STRPOS DIR FILENAME 1 NIL T NIL UPPERCASEARRAY) (* \; "DIR is prefix of FILENAME") DIR) (T (|for| I |from| 1 |bind| LASTDIR C |do| (|if| (OR (NULL (SETQ C (NTHCHARCODE DIR I))) (NEQ C (NTHCHARCODE FILENAME I))) |then| (* \; "Came to end of DIR or a non-matching character. Return the substring of DIR up to the last directory delimiter we saw.") (RETURN (AND LASTDIR (SUBSTRING DIR 1 LASTDIR))) |else| (SELCHARQ C ((/ >) (* \; "end of a subdirectory") (SETQ LASTDIR I)) NIL)))))))) (FB.MAYBE.INSERT.FILE (LAMBDA (FBROWSER NEWNAME OLDITEM CMD) (* \;  "Edited 19-Oct-90 12:32 by gadener") (* |;;;| "If NEWNAME matches the pattern of files displayed in FBROWSER, insert it in that browser and return T. OLDITEM is the tableitem that formed the source of NEWNAME. CMD is the command that created NEWNAME -- Copy or Rename") (LET ((*UPPER-CASE-FILE-NAMES* NIL) FILEINFO N FULLNAME CRDATE CRDATE2 VERSION NEWDATA NEWITEM FILE-UNCERTAIN) (COND ((AND (DIRECTORY.MATCH (|fetch| (FILEBROWSER PREPAREDPATTERN) |of| FBROWSER) NEWNAME) (* |;;|  "Need to check that at least the FB pattern is not longer than the NEWNAME") (GEQ (NCHARS NEWNAME) (SETQ N (SUB1 (|fetch| (FILEBROWSER DIRECTORYSTART) |of| FBROWSER) ))) (* |;;|  "Checks for match up to where the directory part start. i.e. the host part") (STRING-EQUAL NEWNAME (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) :END1 N :END2 N)) (* |;;|  "NEWNAME belongs in this browser, so add it. First create some attributes for it") (SETQ NEWDATA (FB.CREATE.FILEBUCKET FBROWSER NEWNAME (SETQ FILEINFO (COND (OLDITEM (* \;  "Info from old item will do for starters") (APPEND (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| OLDITEM))) ) (T (|for| ATTR |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |collect| (GETFILEINFO NEWNAME (CAR ATTR)))))))) (COND ((NULL.VERSIONP (|fetch| (FBFILEDATA VERSION) |of| NEWDATA)) (* |;;| "Grumble. IFS version of Rename does not return a full file name, due to shortcoming in ftp protocol, so we won't know the version. Best we can do is assume that it's the newest version. If creation date of old file is available, verify that they agree") (|if| (NULL (SETQ FULLNAME (INFILEP NEWNAME))) |then| (* \; "Can't find file?") (SETQ FILE-UNCERTAIN T) |elseif| (NULL (SETQ VERSION (UNPACKFILENAME.STRING FULLNAME 'VERSION NIL 'TENEX))) |then| (* \; "Was versionless file after all, say Unix. Nothing to do. Pass TENEX as ostype because we know the name was in canonical form from device, and don't want periods turned spuriously into semi-colons") |elseif| (OR (NULL (SETQ CRDATE (CL:POSITION 'CREATIONDATE (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER)) )) (NULL (SETQ CRDATE (CL:NTH CRDATE FILEINFO))) (AND (SETQ CRDATE (IDATE CRDATE)) (SETQ CRDATE2 (GETFILEINFO FULLNAME 'ICREATIONDATE)) (= CRDATE2 CRDATE))) |then| (* \;  "Assume we're right about it being newest version") (SETQ NEWDATA (FB.CREATE.FILEBUCKET FBROWSER (SETQ NEWNAME (PROGN (* \;  "Canonicalize NEWNAME -- some cases where final period was left out") (PACKFILENAME.STRING 'BODY NEWNAME 'EXTENSION "" 'VERSION VERSION))) FILEINFO)) |else| (SETQ FILE-UNCERTAIN T)))) (SETQ NEWITEM (|create| TABLEITEM TIDATA _ NEWDATA)) (|if| OLDITEM |then| (* \;  "Update info--some is same as old file, some is new") (|for| TAIL |on| FILEINFO |as| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |unless| (SELECTQ (CAR SPEC) (AUTHOR (* \;  "Rename usually preserves this, but Copy sometimes changes it") (EQ CMD '|Rename|)) ((CREATIONDATE SIZE LENGTH TYPE BYTESIZE) (* \; "These are preserved by both copy and rename, assuming that the source and destination device are the same") T) (PROGN (* \; "Read and Write dates are generally changed. Also, conservatively assume that Copy/Rename could change any attribute we don't know about") NIL)) |do| (RPLACA TAIL (AND (NOT FILE-UNCERTAIN) (GETFILEINFO NEWNAME (CAR SPEC))))) (COND ((AND (EQ CMD '|Rename|) (|fetch| TISELECTED |of| OLDITEM)) (* \;  "If old item was selected, keep the renamed version selected as well") (|replace| TISELECTED |of| NEWITEM |with| T)))) (FB.INSERT.FILE FBROWSER NEWITEM) T))))) (FB.GET.NEW.FILE.SPEC (LAMBDA (OLDNAME BROWSER CMD) (* \; "Edited 22-Nov-88 16:55 by bvm") (* |;;| "For Copy and Rename commands, derives a new name to copy/rename to from OLDNAME. PREFIX if given is a DIRECTORY spec; if not given, we prompt for a destination file. Returns NIL if user aborts") (LET (NEWNAME NAMEFIELD FIELDS DIR) (COND ((NULL (SETQ NEWNAME (FB.PROMPTFORINPUT (CONCAT CMD " file " OLDNAME (SELECTQ CMD (|Rename| " to be: ") (|Copy| " to new file name: ") (SHOULDNT))) (PACKFILENAME.STRING 'DIRECTORY (OR (|fetch| (  FILEBROWSER DEFAULTDIR) |of| BROWSER) (DIRECTORYNAME T)) 'VERSION NIL 'BODY OLDNAME) BROWSER T))) (* \; "Aborted") NIL) ((NULL (SETQ NAMEFIELD (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING NEWNAME)) 'NAME))) (* \; "Assume directory spec") (SETQ NEWNAME (\\ADD.CONNECTED.DIR NEWNAME)) (|replace| (FILEBROWSER DEFAULTDIR) |of| BROWSER |with| NEWNAME) (PACKFILENAME.STRING 'DIRECTORY NEWNAME 'VERSION NIL 'BODY OLDNAME)) ((AND (EQ (NCHARS NAMEFIELD) 0) (OR (NULL (SETQ NAMEFIELD (LISTGET FIELDS 'EXTENSION))) (EQ (NCHARS NAMEFIELD) 0))) (* \;  "Directory spec with some more pieces after it?") (FB.PROMPTWPRINT BROWSER "Failed, malformed name") NIL) (T (* \; "A plain old file name") (|for| TAIL |on| FIELDS |by| (CDDR TAIL) |bind| PREVTAIL |do| (SELECTQ (CAR TAIL) ((HOST DIRECTORY DEVICE) (* \; "Keep these") ) (RETURN (COND ((EQ TAIL FIELDS) (SETQ FIELDS NIL)) (T (RPLACD (CDR PREVTAIL)))))) (SETQ PREVTAIL TAIL)) (COND ((SETQ DIR (COND (FIELDS (SETQ DIR (PACKFILENAME.STRING FIELDS)) (FB.CANONICAL.DIRECTORY (COND ((NEQ (CAR FIELDS) 'HOST) (\\ADD.CONNECTED.DIR DIR)) (T DIR)) BROWSER CMD)) (T (DIRECTORYNAME T)))) (|replace| (FILEBROWSER DEFAULTDIR) |of| BROWSER |with| DIR) (\\ADD.CONNECTED.DIR NEWNAME)))))))) (FB.CANONICAL.DIRECTORY (LAMBDA (DIRNAME FBROWSER CMD) (* \; "Edited 22-Nov-88 16:58 by bvm") (LET* ((PWINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST FBROWSER 'FILEBROWSER))) (OLDTTYSTREAM (TTYDISPLAYSTREAM PWINDOW)) (OLDTTYPROC (TTY.PROCESS (THIS.PROCESS)))) (* \;  "Point tty at our prompt window in case DIRECTORYNAME tries to interact") (CL:UNWIND-PROTECT (COND ((DIRECTORYNAME DIRNAME NIL 'ASK)) ((EQ (FB.YES-OR-NO-P (CL:FORMAT NIL "Directory ~A does not exist yet; ~A anyway?" DIRNAME CMD) FBROWSER) 'Y) DIRNAME)) (TTY.PROCESS OLDTTYPROC) (TTYDISPLAYSTREAM OLDTTYSTREAM) (WINDOWPROP PWINDOW 'PROCESS NIL))))) ) (DEFINEQ (FB.HARDCOPYCOMMAND (LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \;  "Edited 18-Feb-91 10:44 by gadener") (* |;;;| "Produces hardcopy of selected files. Subcommands allow directing output to particular printer, or to a file") (LET ((FILES (FB.SELECTEDFILES BROWSER)) PRINTOPTIONS) (COND ((AND FILES (SELECTQ OPTION (FILE (FB.ALLOW.ABORT BROWSER) (FB.HARDCOPY.TOFILE BROWSER FILES) NIL) (PRINTER (COND ((SETQ PRINTOPTIONS (|GetPrinterName|)) (SETQ PRINTOPTIONS (LIST 'SERVER PRINTOPTIONS)) T))) T)) (FB.ALLOW.ABORT BROWSER) (|for| ITEM |in| FILES |do| (LISTFILES1 (FB.FETCHFILENAME ITEM) PRINTOPTIONS))))))) (FB.HARDCOPY.TOFILE (LAMBDA (BROWSER FILES) (* \;  "Edited 15-Feb-91 17:13 by gadener") (* |;;| "Handle the \"Hardcopy>To File\" command. ") (PROG ((HCOPYFILE (FB.PROMPTFORINPUT (COND ((CDR FILES) "Hardcopy file name pattern: ") (T "Hardcopy file name: ")) (COND ((CDR FILES) (PACKFILENAME.STRING 'NAME '* 'EXTENSION (  \\FB.HARDCOPY.TOFILE.EXTENSION ))) (T (PACKFILENAME.STRING 'VERSION NIL 'EXTENSION (  \\FB.HARDCOPY.TOFILE.EXTENSION ) 'BODY (FB.FETCHFILENAME (CAR FILES))))) BROWSER T)) HCOPYFIELDS PRINTFILETYPE MSG HCOPYTAIL FORE AFT EXT) (COND ((NULL HCOPYFILE) (RETURN))) (COND ((CDR FILES) (* |;;| "Hardcopying multiple files. Take apart the pattern so we can figure out how to make the destination names. We insist that the * be in the name.") (COND ((|for| TAIL |on| (SETQ HCOPYFIELDS (UNPACKFILENAME.STRING HCOPYFILE)) |by| (CDDR TAIL) |bind| HOST HAVEDIRECTORY I |do| (COND ((SETQ I (STRPOS '* (CADR TAIL))) (|if| (NEQ (CAR TAIL) 'NAME) |then| (RETURN (SETQ MSG "Only name portion can contain *") )) (* \; "Take apart name into FORE*AFT") (SETQ HCOPYTAIL (CDR TAIL)) (SETQ FORE (OR (SUBSTRING (CADR TAIL) 1 (SUB1 I)) "")) (SETQ AFT (OR (SUBSTRING (CADR TAIL) (ADD1 I)) ""))) (T (SELECTQ (CAR TAIL) (NAME (RETURN (SETQ MSG "Name must have * for multiple hardcopy files" ))) (EXTENSION (SETQ EXT (MKATOM (U-CASE (CADR TAIL))))) (DIRECTORY (SETQ HAVEDIRECTORY T)) (HOST (SETQ HOST (CADR TAIL))) NIL))) |finally| (|if| (AND HOST (NOT HAVEDIRECTORY)) |then| (* \;  "E.g., {DSK}*.IP. This pattern explicitly has no directory") (|push| HCOPYFIELDS 'DIRECTORY NIL))) (FB.PROMPTWPRINT BROWSER "Bad pattern -- " MSG) (RETURN)))) (T (SETQ EXT (U-CASE (FILENAMEFIELD HCOPYFILE 'EXTENSION))))) (COND ((AND (NULL (SETQ PRINTFILETYPE (|for| TYPE |in| PRINTFILETYPES |when| (FMEMB EXT (CADR (ASSOC 'EXTENSION (CDR TYPE)))) |do| (* \;  "Opencoded PRINTFILETYPE.FROM.EXTENSION because that one's buggy") (RETURN (CAR TYPE))))) (NULL (SETQ PRINTFILETYPE (MENU (|MakeMenuOfImageTypes| "File type?"))))) (RETURN))) (|for| ITEM |in| FILES |bind| (CONVERTERS _ (PRINTFILEPROP PRINTFILETYPE 'CONVERSION)) FILETYPE NAME FN FIELDS |do| (SETQ ITEM (FB.FETCHFILENAME ITEM)) (SETQ FILETYPE (OR (PRINTFILETYPE ITEM) 'TEXT)) (COND ((SETQ FN (LISTGET CONVERTERS FILETYPE)) (FB.PROMPTW.FORMAT BROWSER "~%Writing ~A..." (SETQ NAME (COND ((CDR FILES) (SETQ FIELDS (UNPACKFILENAME.STRING ITEM NIL NIL 'TENEX)) (RPLACA HCOPYTAIL (CONCAT FORE (LISTGET FIELDS 'NAME) AFT)) (CL:APPLY (FUNCTION PACKFILENAME.STRING) 'VERSION NIL (APPEND HCOPYFIELDS FIELDS))) (T HCOPYFILE)))) (SETQ NAME (CL:FUNCALL FN ITEM NAME)) (COND ((LISTP NAME) (* \; "Result is (SOURCE DESTINATION)") (SETQ NAME (CADR NAME)))) (FB.PROMPTWPRINT BROWSER "done.") (FB.MAYBE.INSERT.FILE BROWSER NAME)) (T (FB.PROMPTW.FORMAT BROWSER "~%Failed to hardcopy ~A -- Can't convert a ~A file to format ~A" ITEM FILETYPE PRINTFILETYPE))))))) ) (DEFINEQ (FB.EDITCOMMAND (LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \; "Edited 27-Feb-2021 19:07 by rmk:") (* \; "Edited 1-Feb-88 19:00 by bvm:") (FB.ALLOW.ABORT BROWSER) (|for| FILE |in| (FB.SELECTEDFILES BROWSER) |bind| (*UPPER-CASE-FILE-NAMES* _ NIL) |do| (SETQ FILE (FB.FETCHFILENAME FILE)) (IF (DIRECTORYNAMEP FILE) THEN (FB.BROWSECOMMAND BROWSER) ELSEIF (GETD 'OPENTEXTSTREAM) THEN (FB.EDITCOMMAND.ONEFILE BROWSER FILE OPTION ITEM MENU) ELSE (FB.FASTSEECOMMAND BROWSER KEY ITEM MENU))))) (FB.EDITCOMMAND.ONEFILE (LAMBDA (BROWSER FILE OPTION ITEM MENU) (* \; "Edited 27-Feb-2021 20:07 by rmk:") (* \; "Edited 1-Feb-88 19:00 by bvm:") (* |;;| "Called when we know that FILE is a file, not a directory, and that TEDIT exists. If OPTION is READONLY, we don't want to edit, just view. If FILE is a lisp sourcefile, we execute the font changes by COPY.TEXT.TO.IMAGE.") (* |;;| "We clear the shade stuff here because we don't want the FB to come up on top of our see/edit region. We don't factor it to the top because we want to do whatever heavy lifting (copying files) before. Don't factor to the end because then it is too late--the TEDIT window was up and then buried. (If TEDIT had a don'topen option, we could set things up, then change the shade, then open. We could also do the manufactured title on the window before it shows.") (CL:UNLESS OPTION (SETQ OPTION FB.DEFAULT.EDITOR)) (CL:MULTIPLE-VALUE-BIND (IGNORE CONDITION) (IGNORE-ERRORS (IF (LISPSOURCEFILEP FILE) THEN (SELECTQ OPTION ((LISP NIL TEDIT) (* |;;| "Asks to load prop and edits the coms. We really don't want to use a text editor on a source file.") (* |;;| "The FUNCALL at the bottom is concerning.") (SHADEITEM ITEM MENU FB.ITEMUNSELECTEDSHADE) (PUTMENUPROP MENU 'ITEMSHADE (CONS ITEM FB.ITEMUNSELECTEDSHADE)) (FB.EDITLISPFILE FILE BROWSER)) (READONLY (* \; "READONLY on call from SEE") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (LET ((NSTR (OPENTEXTSTREAM))) (COPY.TEXT.TO.IMAGE STREAM NSTR) (* |;;| "Unshade the item before we create the TEDIT window, and tell FB.FINISH.COMMAND that we did that. That way, the FB window won't pop up on top.") (SHADEITEM ITEM MENU FB.ITEMUNSELECTEDSHADE) (PUTMENUPROP MENU 'ITEMSHADE (CONS ITEM FB.ITEMUNSELECTEDSHADE )) (WINDOWPROP (WFROMDS (TEXTSTREAM (TEDIT NSTR NIL NIL '(READONLY T)))) 'TITLE (CONCAT "SEE window for " (FULLNAME STREAM)))))) (CL:FUNCALL OPTION (MKATOM FILE))) ELSE (SELECTQ OPTION (READONLY (* |;;| "From SEE command. We want to be able to scroll around in the content, can't do that if it isn't random access. So in that case we do a secret NODIRCORE copy and look at that.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (LET ((NSTR)) (CL:UNLESS (RANDACCESSP STREAM) (SETQ NSTR (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW NIL (LIST (LIST 'TYPE (GETFILEINFO STREAM 'TYPE))))) (COPYBYTES STREAM NSTR)) (SHADEITEM ITEM MENU FB.ITEMUNSELECTEDSHADE) (PUTMENUPROP MENU 'ITEMSHADE (CONS ITEM FB.ITEMUNSELECTEDSHADE)) (WINDOWPROP (WFROMDS (TEXTSTREAM (TEDIT (OR NSTR STREAM) NIL NIL '(READONLY T)))) 'TITLE (CONCAT "SEE window for " (FULLNAME STREAM)))))) ((TEDIT NIL) (SHADEITEM ITEM MENU FB.ITEMUNSELECTEDSHADE) (PUTMENUPROP MENU 'ITEMSHADE (CONS ITEM FB.ITEMUNSELECTEDSHADE)) (TEDIT (MKATOM FILE))) (LISP (FB.PROMPTW.FORMAT BROWSER "Failed because not a Lisp source file")) (CL:FUNCALL OPTION (MKATOM FILE))))) (|if| CONDITION |then| (FB.PROMPTW.FORMAT BROWSER "Failed because ~A" CONDITION))))) (FB.EDITLISPFILE (LAMBDA (FILE BROWSER) (* \; "Edited 21-Feb-2021 17:29 by rmk:") (* \; "Edited 28-Jan-88 00:38 by bvm") (PROG (ROOT) (COND ((OR (NOT (STRING-EQUAL (CDAR (GETPROP (SETQ ROOT (U-CASE (ROOTFILENAME FILE))) 'FILEDATES)) FILE)) (NOT (GET ROOT 'FILE)) (NOT (BOUNDP (FILECOMS ROOT)))) (FB.PROMPTW.FORMAT BROWSER "The file ~A is not loaded or is not current." FILE) (COND ((MOUSECONFIRM (CONCAT "(LOAD '" FILE " 'PROP)? ") NIL (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER)) (EXEC-EVAL `(LOAD ',FILE 'PROP))) (T (RETURN))))) (RESETFORM (TTYDISPLAYSTREAM PROMPTWINDOW) (ED ROOT '(FILES :DONTWAIT)))))) (FB.BROWSECOMMAND (LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \; "Edited 20-Feb-2021 20:10 by rmk:") (* \; "Edited 1-Feb-88 18:31 by bvm:") (* |;;;| "view selected file by sprouting a recursive file browser on it") (FB.ALLOW.ABORT BROWSER) (|for| FILE |in| (FB.SELECTEDFILES BROWSER) |bind| (DEPTH _ (|fetch| (FILEBROWSER FBDEPTH) |of| BROWSER)) NAME |do| (SETQ NAME (FB.FETCHFILENAME FILE)) (|if| (OR (FB.DIRECTORYP FILE) (AND (NOT (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER)) (LET* ((FIELDS (UNPACKFILENAME.STRING NAME NIL NIL 'TENEX)) (NAMETAIL (MEMB 'NAME FIELDS)) INTERESTING SUBDIR MAINDIR) (* \; "File is not syntactically a directory. Perhaps the device returned foo.;1 instead of foo>. We know ns servers don't do this.") (|for| TAIL |on| NAMETAIL |by| (CDDR TAIL) |do| (|if| (OR (EQ 0 (NCHARS (CADR TAIL))) (AND (EQ (CAR TAIL) 'VERSION) (|if| (NEQ (MKATOM (CADR TAIL)) 1) |then| (* \;  "It has a version--most unlikely for a directory") (RETURN NIL) |else| T))) |then| (* \;  "turn empty or boring fields into omitted fields") (RPLACA (CDR TAIL) NIL) |else| (SETQ INTERESTING T)) |finally| (SETQ FIELDS (LDIFF FIELDS NAMETAIL)) (|if| INTERESTING |then| (* |;;| "Would like just to do (CL:APPLY (function packfilename.string) (nconc fields `(SUBDIRECTORY subdir))), but PACKFILENAME.STRING doesn't seem to know about unix.") (SETQ MAINDIR (LISTGET FIELDS 'DIRECTORY)) (SETQ SUBDIR (CL:APPLY (FUNCTION PACKFILENAME.STRING) NAMETAIL)) (LISTPUT FIELDS 'DIRECTORY (|if| (NULL MAINDIR) |then| SUBDIR |else| (CONCAT MAINDIR (|if| (STRPOS "/" MAINDIR) |then| "/" |elseif| (STRPOS ">" MAINDIR) |then| ">" |elseif| (EQ (GETHOSTINFO (LISTGET FIELDS 'HOST) 'OSTYPE) 'UNIX) |then| (* \;  "Resort to GETHOSTINFO only if the name hasn't given it away yet.") "/" |else| ">") SUBDIR)))) (RETURN (DIRECTORYNAMEP (SETQ NAME (CL:APPLY (FUNCTION PACKFILENAME.STRING) FIELDS)))))))) |then| (ADD.PROCESS `(,(FUNCTION FILEBROWSER) ',NAME ',(MAPCAR (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER) (FUNCTION CAR)) ,@(AND DEPTH `('(:DEPTH ,DEPTH))))) |else| (FB.PROMPTW.FORMAT BROWSER "~A is not a directory" NAME))))) ) (DEFINEQ (FB.FASTSEECOMMAND (LAMBDA (BROWSER KEY ITEM MENU UNFORMATTED) (* \; "Edited 30-Aug-94 19:46 by jds") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) FILELIST SEEWINDOW) (OR (SETQ FILELIST (FB.SELECTEDFILES BROWSER)) (RETURN)) (FB.ALLOW.ABORT BROWSER) (COND ((AND (NOT (WINDOWP (SETQ SEEWINDOW (|fetch| (FILEBROWSER SEEWINDOW) |of| BROWSER)))) (FOR FILE IN FILELIST THEREIS (* |;;| "Only need a SEE window if there's going to be a file to really SEE, as opposed to directories to browse.") (OR (UNPACKFILENAME (FB.FETCHFILENAME FILE) 'NAME) (UNPACKFILENAME (FB.FETCHFILENAME FILE) 'EXTENSION)))) (* \; "Create the SEE window") (SETQ SEEWINDOW (CREATEW NIL "SEE window")) (DSPSCROLL T SEEWINDOW) (|replace| (FILEBROWSER SEEWINDOW) |of| BROWSER |with| SEEWINDOW) (WINDOWPROP SEEWINDOW 'PAGEFULLFN (FUNCTION FB.SEEFULLFN)) (WINDOWADDPROP SEEWINDOW 'CLOSEFN (FUNCTION (LAMBDA (W) (WINDOWPROP W 'INUSE NIL) (DEL.PROCESS (WINDOWPROP W 'PROCESS)))))) ) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (WINDOW) (WINDOWPROP WINDOW 'PROCESS NIL) (* \;  "Remove process attached here by ttydisplaystream") (LET ((BUTTONS (WINDOWPROP WINDOW (WINDOWPROP WINDOW 'MORETYPE)))) (|if| (AND BUTTONS (OPENWP BUTTONS)) |then| (* \;  "If More button still open, detach it") (DETACHWINDOW BUTTONS) (CLOSEW BUTTONS))))) SEEWINDOW)) (TTYDISPLAYSTREAM SEEWINDOW) (* \;  "Has to be our TTYDISPLAYSTREAM in order for page holding to work") (|for| TAIL |on| FILELIST |do| (CL:CATCH :NEXT (FB.FASTSEE.ONEFILE BROWSER (FB.FETCHFILENAME (CAR TAIL)) SEEWINDOW UNFORMATTED (CDR TAIL))))))) (FB.FASTSEE.ONEFILE (LAMBDA (BROWSER FILE WINDOW UNFORMATTED MORE) (* \; "Edited 21-Feb-2021 14:46 by rmk:") (* \; "Edited 20-Nov-2000 14:23 by rmk:") (* \; "Edited 19-Aug-91 13:06 by jds") (COND ((DIRECTORYNAMEP FILE) (* |;;| "We're trying to SEE a directory. Browse it instead. ") (FB.BROWSECOMMAND BROWSER)) (T (* |;;| "We're really browsing a file here, so SEE it.") (CLEARW WINDOW) (WINDOWPROP WINDOW 'TITLE (CONCAT "Viewing " FILE)) (CL:MULTIPLE-VALUE-BIND (STREAM CONDITION) (IGNORE-ERRORS (OPENSTREAM FILE 'INPUT NIL '((TYPE TEXT) (SEQUENTIAL T)))) (|if| CONDITION |then| (* |;;| "Failed on this file. If this was the only file, the message can be a little more terse (which is desirable, because the typical message is \"File not found xxx\")") (FB.PROMPTW.FORMAT BROWSER "~:[Failed~;~:*Couldn't see ~A~] because ~A" (AND MORE FILE) CONDITION) |else| (RESETLST (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (STREAM WINDOW) (AND RESETSTATE (OPENWP WINDOW) (WINDOWPROP WINDOW 'TITLE (CONCAT (WINDOWPROP WINDOW 'TITLE) " -- " "Aborted"))) (CLOSEF STREAM))) STREAM WINDOW)) (WINDOWPROP WINDOW 'MORETYPE (COND (MORE 'YETMOREBUTTONS) (T 'LASTMOREBUTTONS))) (COND (UNFORMATTED (COPYCHARS STREAM WINDOW)) (T (PFCOPYBYTES STREAM WINDOW))) (WINDOWPROP WINDOW 'TITLE (CONCAT (WINDOWPROP WINDOW 'TITLE) " -- " "Finished")) (COND (MORE (* \; "Wait for OK to proceed") (FB.SEEFULLFN (WINDOWPROP WINDOW 'DSP) 'FINISHEDMOREBUTTONS)))))))))) (FB.SEEFULLFN (LAMBDA (DSP PROP) (* |bvm:| "18-Sep-85 23:29") (* |;;| "PAGEFULLFN for a fast SEE window") (LET* ((WINDOW (WFROMDS DSP)) (BUTTONS (WINDOWPROP WINDOW (OR PROP (SETQ PROP (WINDOWPROP WINDOW 'MORETYPE))))) (EVENT (WINDOWPROP WINDOW 'MOREEVENT))) (COND ((NOT BUTTONS) (SETQ BUTTONS (|create| MENU ITEMS _ (SELECTQ PROP (YETMOREBUTTONS '(("More" MORE "View another screenfull of the file") (" Next File " NEXT "Abort view of this file, go on to next one" ) ("Abort" ABORT "Abort viewing of this and any further files" ))) (FINISHEDMOREBUTTONS '((" Next File " NEXT "Go on to view the next file") ("Abort" ABORT "Abort the SEE command -- see no more files" ))) '((" More " MORE "View another screenfull of the file" ) (" Abort " ABORT "Abort view; allow this window to be re-used" ))) MENUROWS _ 1 WHENSELECTEDFN _ (FUNCTION FB.SEEBUTTONFN) CENTERFLG _ T)) (SETQ BUTTONS (ADDMENU BUTTONS (CREATEW (CREATEREGION 0 0 (WIDTHIFWINDOW (|fetch| (MENU IMAGEWIDTH ) |of| BUTTONS) FB.MORE.BORDER) (HEIGHTIFWINDOW (|fetch| (MENU IMAGEHEIGHT) |of| BUTTONS) NIL FB.MORE.BORDER)) NIL FB.MORE.BORDER T) NIL T)) (WINDOWPROP WINDOW PROP BUTTONS))) (COND ((NOT EVENT) (WINDOWPROP WINDOW 'MOREEVENT (SETQ EVENT (CREATE.EVENT (WINDOWPROP WINDOW 'TITLE)))))) (ATTACHWINDOW BUTTONS WINDOW (COND ((GREATERP (|fetch| (REGION HEIGHT) |of| (WINDOWPROP BUTTONS 'REGION)) (|fetch| (REGION BOTTOM) |of| (WINDOWPROP WINDOW 'REGION))) 'TOP) (T 'BOTTOM)) 'LEFT) (|do| (TOTOPW BUTTONS) (AWAIT.EVENT EVENT) |repeatuntil| (WINDOWPROP WINDOW 'MOREOK NIL))))) (FB.SEEBUTTONFN (LAMBDA (ITEM MENU) (* \; "Edited 28-Jan-88 00:05 by bvm") (* |;;;| "WHENSELECTEDFN for the More/Abort menu") (LET* ((MENUW (WFROMMENU MENU)) (WINDOW (MAINWINDOW MENUW))) (DETACHWINDOW MENUW) (* \; "Take the buttons down") (CLOSEW MENUW) (SELECTQ (CADR ITEM) (MORE (* \;  "Notify pagefullfn that it can continue") (WINDOWPROP WINDOW 'MOREOK T) (NOTIFY.EVENT (WINDOWPROP WINDOW 'MOREEVENT))) (NEXT (* \;  "Throw to the loop that is displaying each file") (PROCESS.EVAL (WINDOWPROP WINDOW 'PROCESS) '(CL:THROW :NEXT))) (ABORT (* \; "Kill it") (DEL.PROCESS (WINDOWPROP WINDOW 'PROCESS))) (SHOULDNT))))) ) (DEFINEQ (FB.LOADCOMMAND (LAMBDA (BROWSER KEY ITEM MENU LOADOP) (* |bvm:| "18-Sep-85 17:16") (LET ((FILES (FB.SELECTEDFILES BROWSER))) (AND FILES (ADD.PROCESS (LIST (FUNCTION FB.OPERATE.ON.FILES) (KWOTE (OR LOADOP (FUNCTION LOAD))) (KWOTE FILES)) 'NAME 'LOAD 'BEFOREEXIT 'DON\'T))))) (FB.COMPILECOMMAND (LAMBDA (BROWSER KEY ITEM MENU COMPILEOP) (* \; "Edited 5-Mar-87 17:39 by bvm:") (LET ((FILES (FB.SELECTEDFILES BROWSER))) (AND FILES (ADD.PROCESS (LIST (FUNCTION FB.OPERATE.ON.FILES) (KWOTE (OR COMPILEOP *DEFAULT-CLEANUP-COMPILER*)) (KWOTE FILES)) 'NAME 'COMPILE 'BEFOREEXIT 'DON\'T))))) (FB.OPERATE.ON.FILES (LAMBDA (FN FILELIST) (* \; "Edited 4-Feb-88 15:14 by bvm:") (LET (LDFLG FORMS) (SELECTQ FN ((PROP SYSLOAD) (SETQ LDFLG FN) (SETQ FN 'LOAD)) NIL) (SETQ FORMS (|for| FILEENTRY |in| FILELIST |collect| `(,FN ',(FB.FETCHFILENAME FILEENTRY) ,@(AND LDFLG `(',LDFLG))))) (EXEC-EVAL (|if| (CDR FORMS) |then| (CONS 'PROGN FORMS) |else| (CAR FORMS))) (CLOSEW (TTYDISPLAYSTREAM))))) ) (DEFINEQ (FB.UPDATECOMMAND (LAMBDA (BROWSER) (* |bvm:| "27-Sep-85 12:30") (COND ((FB.MAYBE.EXPUNGE BROWSER '|Recompute|) (FB.UPDATEBROWSERITEMS BROWSER))))) (FB.MAYBE.EXPUNGE (LAMBDA (BROWSER COMMAND) (* \; "Edited 22-Feb-2021 12:33 by rmk:") (* |bvm:| "27-Sep-85 12:30") (* |;;;| "If BROWSER has files marked for deletion, ask whether user wants to expunge them. Returns T if it is okay to proceed, NIL if not (user aborted or expunge failed)") (COND ((EQ (|fetch| (FILEBROWSER DELETEDFILES) |of| BROWSER) 0) T) (T (FB.PROMPTWPRINT BROWSER "Some files are marked for deletion. Do you want to expunge them first?") (SELECTQ (MENU (FB.EXPUNGE?.MENU)) (EXPUNGE (* \;  "Do expunge in another process, not here in mouse") (FB.EXPUNGECOMMAND BROWSER NIL NIL NIL COMMAND)) (NOEXPUNGE T) NIL))))) (FB.UPDATEBROWSERITEMS (LAMBDA (BROWSER) (* \; "Edited 30-Aug-94 19:46 by jds") (RESETLST (PROG ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (FONT FB.BROWSERFONT) PATTERN INFOWANTED FILEGENERATOR FILENAME NOW INDEX WIDENED CONDITION) (FB.ALLOW.ABORT BROWSER) (COND ((SETQ PATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER))) ((SETQ PATTERN (FB.GET.NEWPATTERN BROWSER)) (* \;  "Didn't have a pattern before--got one now") (FB.SETNEWPATTERN BROWSER PATTERN)) (T (* \; "Refused to give me a pattern") (RETURN))) (PROGN (* \; "Restore browser to empty state--clear the counter window, set the title, remove any items, reset counters.") (|replace| (FILEBROWSER INFODISPLAYED) |of| BROWSER |with| (SETQ INFOWANTED (|for| SPEC |in| FB.INFO.FIELDS |bind| (WANTED _ (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER)) W PROTO |when| (MEMB (|fetch| (INFOFIELD INFONAME) |of| SPEC) WANTED) |collect| (SETQ SPEC (COPY SPEC)) (|if| (SETQ PROTO (|fetch| (INFOFIELD INFOPROTOTYPE) |of| SPEC)) |then| (* \;  "Have prototypical example, use it to get better width estimate.") (SETQ W (STRINGWIDTH PROTO FONT)) (|replace| (INFOFIELD INFOWIDTH) |of| SPEC |with| (+ W (TIMES 2 (CHARWIDTH (CHARCODE X) FONT)))) (|if| (LISTP (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) |then| (RPLACA (CDR (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) W))) SPEC))) (FB.SET.BROWSER.TITLE BROWSER) (CLEARW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER)) (CLEARW (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (* \;  "Clear header window in case it has been scrolled.") (TB.REPLACE.ITEMS TBROWSER NIL) (|replace| (FILEBROWSER FBREADY) |of| BROWSER |with| NIL) (TB.SET.FONT TBROWSER FONT) (|replace| (FILEBROWSER BROWSERFONT) |of| BROWSER |with| FONT) (FB.SET.DEFAULT.NAME.WIDTH BROWSER) (|replace| (FILEBROWSER DELETEDFILES) |of| BROWSER |with| (|replace| (FILEBROWSER DELETEDPAGES) |of| BROWSER |with| (|replace| (FILEBROWSER TOTALPAGES) |of| BROWSER |with| (|replace| (FILEBROWSER TOTALFILES) |of| BROWSER |with| 0)))) (|replace| (FILEBROWSER SORTMENU) |of| BROWSER |with| (|replace| (FILEBROWSER PATTERNPARSED?) |of| BROWSER |with| NIL))) (|if| (SETQ INDEX (OR (CL:POSITION 'SIZE INFOWANTED :KEY (FUNCTION CAR)) (CL:POSITION 'LENGTH INFOWANTED :KEY (FUNCTION CAR)))) |then| (|replace| (FILEBROWSER SIZEINDEX) |of| BROWSER |with| INDEX)) (|replace| (FILEBROWSER PAGECOUNT?) |of| BROWSER |with| (AND INDEX (CAR (CL:NTH INDEX INFOWANTED)))) (PROGN (|replace| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER SORTBY) |of| BROWSER |with| (FUNCTION FB.NAMES.DECREASING.VERSION))) (CL:MULTIPLE-VALUE-SETQ (FILEGENERATOR CONDITION) (IGNORE-ERRORS (LET* ((DESIREDPROPS (MAPCAR INFOWANTED (FUNCTION CAR))) (NSP (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER) ) (DEPTH (OR (|fetch| (FILEBROWSER FBDEPTH) |of| BROWSER) (|if| NSP |then| (* \;  "FILING.ENUMERATION.DEPTH is significant for NS servers") FILING.ENUMERATION.DEPTH))) (FILING.ENUMERATION.DEPTH (OR DEPTH FILING.ENUMERATION.DEPTH))) (DECLARE (SPECVARS FILING.ENUMERATION.DEPTH)) (FB.PROMPTW.FORMAT BROWSER "~%Enumerating ~A ~@[to depth ~D ~]..." PATTERN (FIXP DEPTH)) (|if| (AND NSP (|fetch| (FILEBROWSER PAGECOUNT?) |of| BROWSER) (OR DEPTH (NOT (UNPACKFILENAME.STRING PATTERN 'DIRECTORY)))) |then| (* \; "Ask for SUBTREE.SIZE also, so we can give page estimates of subdirectories, or in the case of enumerating a host, the top-level directories") (|push| DESIREDPROPS 'SUBTREE.SIZE)) (|replace| (FILEBROWSER FBDISPLAYEDDEPTH) |of| BROWSER |with| (|replace| (FILEBROWSER FBCOMPUTEDDEPTH) |of| BROWSER |with| (OR (FIXP DEPTH) 0))) (\\GENERATEFILES PATTERN DESIREDPROPS '(SORT RESETLST))))) (|if| CONDITION |then| (FB.PROMPTW.FORMAT BROWSER "Failed because ~A" CONDITION) (RETURN)) (SETQ NOW (FB.DATE)) (* \;  "Time as of which the enumeration is reasonably valid") (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (|while| (SETQ FILENAME (\\GENERATENEXTFILE FILEGENERATOR)) |bind| LASTFILEDATA NEWFILEDATA PREVGROUPDATA OTHERFILES |do| (* |;;| "For each file, create an FBFILEDATA object. Gather together files with the same name, different version, so that we can sort versions. Thus, the display is always (at least) one file behind the generator: LASTFILEDATA is the first item of a given name, OTHERFILES are the remaining versions. PREVGROUPDATA is representative of the previous group.") (COND ((LISTP FILENAME) (* \;  "Old kind of generator. Extinct?") (SETQ FILENAME (CONCATCODES FILENAME)))) (SETQ NEWFILEDATA (FB.CREATE.FILEBUCKET BROWSER FILENAME (FB.GETALLFILEINFO BROWSER FILEGENERATOR INFOWANTED) LASTFILEDATA)) (COND ((AND LASTFILEDATA (EQ (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| LASTFILEDATA) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| NEWFILEDATA))) (* \; "This file same name as previous one, so save it in case we need to sort versions. Note that FB.CREATE.FILEBUCKET canonicalizes the VERSIONLESSNAME, so EQ suffices") (|push| OTHERFILES NEWFILEDATA)) (T (COND ((AND LASTFILEDATA (OR (NOT (|fetch| (FBFILEDATA DIRECTORYFILEP) |of| LASTFILEDATA)) (NOT (STRPOS (|fetch| (FBFILEDATA FILENAME ) |of| LASTFILEDATA) (|fetch| (FBFILEDATA FILENAME) |of| NEWFILEDATA) 1 NIL T NIL UPPERCASEARRAY)))) (* |;;| "Add the previous group we have accumulated. Second clause says not to add a line for a subdirectory file which is not a leaf, i.e., for which there are files below it in the enumeration (it would be nice if NS filing did this filtering itself).") (FB.ADD.FILEGROUP TBROWSER BROWSER LASTFILEDATA OTHERFILES PREVGROUPDATA) (SETQ PREVGROUPDATA LASTFILEDATA))) (SETQ OTHERFILES NIL) (SETQ LASTFILEDATA NEWFILEDATA))) |finally| (AND LASTFILEDATA (FB.ADD.FILEGROUP TBROWSER BROWSER LASTFILEDATA OTHERFILES PREVGROUPDATA))) (COND ((EQ (TB.NUMBER.OF.ITEMS TBROWSER) 0) (FB.PROMPTWPRINT BROWSER 'CLEAR "No files in group " PATTERN)) (T (FB.PROMPTWPRINT BROWSER '|done|) (SETQ WIDENED (FB.MAYBE.WIDEN.NAMES BROWSER)) (COND ((OR (FB.ADJUST.DATE.WIDTH BROWSER INFOWANTED) WIDENED) (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (TB.REDISPLAY.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)))))) (FB.SET.BROWSER.TITLE BROWSER NOW) (|replace| (FILEBROWSER FBREADY) |of| BROWSER |with| T) (FB.DISPLAY.COUNTERS BROWSER))))) (FB.DATE (LAMBDA NIL (* \; "Edited 21-Jan-88 18:40 by bvm") (LET ((DT (DATE (DATEFORMAT DAY.OF.WEEK DAY.SHORT NO.SECONDS)))) (* |;;|  "DT is in the form \"dd-mon-yy hh:mm (day)\". Turn it into \"hh:mm day dd-mon-yy\".") (CONCAT (SUBSTRING DT 11 16) (SUBSTRING DT 18 20) " " (SUBSTRING DT (|if| (EQ (CHCON1 DT) (CHARCODE SPACE)) |then| (* \; "Trim leading space from date") 2 |else| 1) 9))))) (FB.ADJUST.DATE.WIDTH (LAMBDA (BROWSER INFOWANTED) (* \; "Edited 30-Aug-94 19:40 by jds") (* |;;| "Adjust the expected with field of any date fields (other than the last) to reflect the width of actual dates this device returns. Returns T if it did anything.") (|for| TAIL |on| INFOWANTED |as| INDEX |from| 0 |while| (CDR TAIL) |bind| (FONT _ (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER)) SPEC RESULT |when| (AND (EQ (|fetch| (INFOFIELD INFOFORMAT) |of| (SETQ SPEC (CAR TAIL))) 'DATE) (TB.FIND.ITEM (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION (LAMBDA (TBROWSER ITEM) (|if| (SETQ ITEM (CL:NTH INDEX (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| ITEM))) ) |then| (* |;;| "Got a sample date. Assuming all dates have the same number of characters, compute a width that fits this date plus a couple spaces. Computation here for variable-width font assumes \"MAY\" is about as wide as you get, and finesses the issue of whether this date happens to start with leading space and/or contain some especially skinny letters.") (|replace| (INFOFIELD INFOWIDTH) |of| SPEC |with| (+ (STRINGWIDTH "XX99-MAY-88 99:99:99" FONT) (|if| (> (NCHARS ITEM) 18) |then| (* \;  "Have a time-zone, too, or something") (STRINGWIDTH (SUBSTRING ITEM 19) FONT) |else| 0))) T))))) |do| (SETQ RESULT T) |finally| (RETURN RESULT)))) (FB.SET.BROWSER.TITLE (LAMBDA (BROWSER TIME) (* \; "Edited 21-Jan-88 18:37 by bvm") (* |;;| "(Re)display the title on BROWSER's window. If Time is supplied, it is the time at which the enumeration happened, and we include it in the title. Title is not changed if user supplied own title.") (COND ((NOT (|fetch| (FILEBROWSER FIXEDTITLE) |of| BROWSER)) (WINDOWPROP (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER) 'TITLE (|if| TIME |then| (CONCAT (|fetch| (FILEBROWSER PATTERN) |of| BROWSER) " at " TIME) |else| (CONCAT (|fetch| (FILEBROWSER PATTERN) |of| BROWSER) " browser"))))))) (FB.MAYBE.WIDEN.NAMES (LAMBDA (BROWSER) (* |bvm:| "18-Oct-85 17:32") (* |;;;| "Examines the OVERFLOWWIDTHS field to see if we should widen the name area of the browser, shoving everything else to the right. If it changes the width, returns T so that caller knows whether to update display") (LET ((OVERFLOW (|fetch| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER)) (CURRENTSTART (|fetch| (FILEBROWSER INFOSTART) |of| BROWSER)) THRESHOLD) (COND (OVERFLOW (* \;  "See if enough files were too wide for print spec") (SETQ THRESHOLD (IMIN (IMAX (FIXR (FTIMES (|fetch| (FILEBROWSER TOTALFILES ) |of| BROWSER) FB.OVERFLOW.MAXFRAC)) 1) FB.OVERFLOW.MAXABSOLUTE)) (|for| PAIR |in| OVERFLOW |when| (AND (IGREATERP (CAR PAIR) CURRENTSTART) (LESSP (SETQ THRESHOLD (IDIFFERENCE THRESHOLD (CADR PAIR))) 0)) |do| (* \;  "Stop here! Any further than this and we would have more than the max files overflowing") (|replace| (FILEBROWSER INFOSTART) |of| BROWSER |with| (CAR PAIR)) (RETURN T))))))) (FB.SET.DEFAULT.NAME.WIDTH (LAMBDA (BROWSER) (* |bvm:| "18-Oct-85 17:54") (LET ((FONT (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER))) (|replace| (FILEBROWSER INFOSTART) |of| BROWSER |with| (IPLUS (|replace| (FILEBROWSER NAMEOVERHEAD) |of| BROWSER |with| (IPLUS (DSPLEFTMARGIN NIL (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (CHARWIDTH (CHARCODE SPACE) FONT) (CHARWIDTH (CHARCODE \;) FONT))) FB.DEFAULT.NAME.WIDTH)) (|replace| (FILEBROWSER DIGITWIDTH) |of| BROWSER |with| (CHARWIDTH (CHARCODE 8) FONT)) (|replace| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER |with| NIL)))) (FB.CREATE.FILEBUCKET (LAMBDA (BROWSER FILENAME FILEINFO LASTFILEDATA) (* \; "Edited 1-Feb-88 14:44 by bvm:") (* |;;| "Create a FBFILEDATA encapsulating FILENAME and its FILEINFO. If LASTFILEDATA is supplied, it is the filedata from the previous file parsed, which we make use of to create canonical VERSIONLESSNAME fields.") (|if| (NOT (STRINGP FILENAME)) |then| (* \;  "Some things are nicer if we force everything to be a string.") (SETQ FILENAME (STRING FILENAME))) (COND ((NULL (|fetch| (FILEBROWSER PATTERNPARSED?) |of| BROWSER)) (FB.ANALYZE.PATTERN BROWSER FILENAME))) (LET ((STARTOFNAME (|fetch| (FILEBROWSER NAMESTART) |of| BROWSER)) (NAMELENGTH (NCHARS FILENAME)) (VERSION 0) (DEPTH 0) STARTOFSHORTNAME LASTDIR PREVDIR LASTNAMECHAR HASDIRPREFIX DIRP ATTR TEM NEWFILEDATA) (SETQ LASTNAMECHAR NAMELENGTH) (|bind| (DEC _ 1) CH |while| (DIGITCHARP (SETQ CH (NTHCHARCODE FILENAME LASTNAMECHAR))) |do| (|add| VERSION (TIMES (- CH (CHARCODE 0)) DEC)) (SETQ DEC (TIMES 10 DEC)) (SETQ LASTNAMECHAR (SUB1 LASTNAMECHAR)) |finally| (* \; "not a version char") (COND ((EQ CH (CHARCODE \;)) (* \; "Pull off the version from the end, so that we can sort with it, etc. Note that we assume that all devices have converted native syntax to Lisp here.") (SETQ LASTNAMECHAR (SUB1 LASTNAMECHAR ))) (T (SETQ VERSION 0) (* \; "Null version") (SETQ LASTNAMECHAR NIL)))) (SETQ NEWFILEDATA (|if| (AND LASTFILEDATA (STRING-EQUAL (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| LASTFILEDATA) FILENAME :END2 (OR LASTNAMECHAR NAMELENGTH))) |then| (* \;  "This file is just like the previous one, except for attributes, full name and version") (|create| FBFILEDATA |using| LASTFILEDATA) |else| (|for| (N _ STARTOFNAME) |do| (SELCHARQ (NTHCHARCODE FILENAME (|add| N 1)) ((> /) (SETQ PREVDIR LASTDIR) (SETQ LASTDIR N) (|add| DEPTH 1)) (\' (* \; "Next char is quoted") (|add| N 1)) (NIL (RETURN)) NIL)) (|if| (EQ LASTDIR NAMELENGTH) |then| (* \;  "It's a directory name (e.g., with ns), so make the name be the last subdirectory") (SETQ LASTDIR PREVDIR) (SETQ DIRP T) (|add| DEPTH -1)) (COND (LASTDIR (* \;  "We found a directory delimiter following the common directory prefix of the pattern. ") (SETQ HASDIRPREFIX T) (SETQ STARTOFSHORTNAME (ADD1 LASTDIR)) (* \; "Directoryless name starts here") (COND ((NOT (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER )) (* \; "Use short name if allowed.") (SETQ STARTOFNAME STARTOFSHORTNAME)))) (T (SETQ STARTOFSHORTNAME STARTOFNAME))) (* \;  "Note optimization: SUBDIREND is zero (SUBDIRECTORY null) when HASDIRPREFIX is NIL.") (|create| FBFILEDATA STARTOFPNAME _ STARTOFNAME VERSIONLESSNAME _ (COND (LASTNAMECHAR (SUBSTRING FILENAME 1 LASTNAMECHAR)) (T FILENAME)) SUBDIREND _ (OR LASTDIR 0) STARTOFNAME _ STARTOFSHORTNAME HASDIRPREFIX _ HASDIRPREFIX DIRECTORYFILEP _ DIRP FILEDEPTH _ DEPTH))) (|replace| (FBFILEDATA FILENAME) |of| NEWFILEDATA |with| FILENAME) (|replace| (FBFILEDATA VERSION) |of| NEWFILEDATA |with| VERSION) (|replace| (FBFILEDATA FILEINFO) |of| NEWFILEDATA |with| FILEINFO) (|replace| (FBFILEDATA SIZE) |of| NEWFILEDATA |with| (AND (SETQ ATTR (|fetch| (FILEBROWSER PAGECOUNT?) |of| BROWSER)) (SETQ TEM (CL:NTH (|fetch| (FILEBROWSER SIZEINDEX) |of| BROWSER) FILEINFO)) (SELECTQ ATTR (LENGTH (FOLDHI TEM BYTESPERPAGE)) TEM))) (FB.CHECK.NAME.LENGTH BROWSER NEWFILEDATA) (COND ((SETQ ATTR (|fetch| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER)) (SETQ ATTR (CL:NTH (|fetch| (FILEBROWSER SORTINDEX) |of| BROWSER) FILEINFO)) (COND ((AND ATTR (|fetch| (FILEBROWSER SORTBYDATE) |of| BROWSER)) (SETQ ATTR (IDATE ATTR)))) (|replace| (FBFILEDATA SORTVALUE) |of| NEWFILEDATA |with| ATTR))) NEWFILEDATA))) (FB.CHECK.NAME.LENGTH (LAMBDA (BROWSER FILEDATA) (* \; "Edited 25-Jan-88 15:44 by bvm") (* |;;;| "Checks the name in FILEDATA to see if printing it would overflow the space set aside for the name column in the browser. If so, updates some information that will help us decide later whether to expand the column") (LET ((PRINTLENGTH (+ (STRINGWIDTH (|fetch| (FBFILEDATA PRINTNAME) |of| FILEDATA) (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER)) (|fetch| (FILEBROWSER NAMEOVERHEAD) |of| BROWSER)))) (COND ((>= PRINTLENGTH (|fetch| (FILEBROWSER INFOSTART) |of| BROWSER)) (* |;;| "Name is longer than allotted space in browser. Shall we allot more space? Don't know until we're thru. For now, record a list of elements (width occurrences), where each name is recorded in the closest entry") (LET ((OVERFLOW (|fetch| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER)) (SPACING (|fetch| (FILEBROWSER OVERFLOWSPACING) |of| BROWSER))) (COND ((OR (NULL OVERFLOW) (> PRINTLENGTH (CAAR OVERFLOW))) (|replace| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER |with| (CONS (LIST PRINTLENGTH 1) OVERFLOW))) (T (|for| (TAIL _ OVERFLOW) |bind| PREVTAIL |when| (OR (NULL (SETQ TAIL (CDR (SETQ PREVTAIL TAIL)))) (> PRINTLENGTH (CAR (CAR TAIL)))) |do| (* \;  "Longer than some previously recorded length, so either add a new entry or bump the preceding one") (COND ((< PRINTLENGTH (- (CAR (CAR PREVTAIL)) SPACING)) (RPLACD PREVTAIL (CONS (LIST PRINTLENGTH 1) TAIL))) (T (|add| (CADR (CAR PREVTAIL)) 1))) (RETURN)))))))))) (FB.ADD.FILEGROUP (LAMBDA (TBROWSER FBROWSER FIRSTDATA OTHERDATA PREVDATA) (* \; "Edited 1-Feb-88 14:43 by bvm:") (* |;;| "Appends to FBROWSER the set of files FIRSTDATA plus each of OTHERDATA, all of which are known to have the same name save version number. PREVDATA is representative of the last item we inserted.") (COND ((AND (NOT (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| FBROWSER)) (NOT (|if| PREVDATA |then| (EQ.DIRECTORYP PREVDATA FIRSTDATA) |else| (NULL.DIRECTORYP FIRSTDATA))))(* \;  "The new files have a different subdirectory, so insert a non-selectable line item here") (FB.INSERT.DIRECTORY TBROWSER FBROWSER FIRSTDATA))) (COND (OTHERDATA (* \;  "More than one file to add, so sort versions") (|for| ITEM |in| (SORT (|for| D |in| (CONS FIRSTDATA OTHERDATA) |collect| (|create| TABLEITEM TIDATA _ D)) (FUNCTION FB.DECREASING.VERSION)) |do| (FB.ADD.FILE TBROWSER FBROWSER ITEM))) (T (FB.ADD.FILE TBROWSER FBROWSER (|create| TABLEITEM TIDATA _ FIRSTDATA)))))) (FB.INSERT.DIRECTORY (LAMBDA (TBROWSER FBROWSER DATAWITHSUBDIR BEFOREITEM) (* \; "Edited 25-Jan-88 17:13 by bvm") (TB.INSERT.ITEM TBROWSER (FB.MAKE.SUBDIRECTORY.ITEM FBROWSER DATAWITHSUBDIR) BEFOREITEM))) (FB.MAKE.SUBDIRECTORY.ITEM (LAMBDA (FBROWSER DATAWITHSUBDIR) (* \; "Edited 26-Jan-88 10:58 by bvm") (* |;;;| "Creates a TABLEITEM containing a subdirectory line identifying the subdirectory in DATAWITHSUBDIR. If item has no subdirectory, we use the browser's pattern directory") (LET* ((SUBDIRECTORY (OR (|fetch| (FBFILEDATA SUBDIRECTORY) |of| DATAWITHSUBDIR) (SUBSTRING (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) 1 (SUB1 (|fetch| (FILEBROWSER NAMESTART) |of| FBROWSER) )))) (DIRSTART (|fetch| (FILEBROWSER DIRECTORYSTART) |of| FBROWSER))) (|create| TABLEITEM TIUNSELECTABLE _ T TIDATA _ (|create| FBFILEDATA FILENAME _ SUBDIRECTORY STARTOFPNAME _ (|if| (<= DIRSTART (NCHARS SUBDIRECTORY)) |then| DIRSTART |else| (* \; "No directory--use whole name") 1) VERSIONLESSNAME _ SUBDIRECTORY DIRECTORYP _ T))))) (FB.ADD.FILE (LAMBDA (TBROWSER FBROWSER ITEM BEFOREITEM) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Inserts one file in TBROWSER / FBROWSER before item BEFOREITEM or at end if BEFOREITEM is NIL") (LET ((SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM)))) (COND (SIZE (|add| (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) SIZE))) (|add| (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER) 1) (TB.INSERT.ITEM TBROWSER ITEM BEFOREITEM)))) (FB.INSERT.FILE (LAMBDA (BROWSER FILE) (* \; "Edited 25-Jan-88 18:31 by bvm") (LET ((TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (FBSORTFN (|fetch| (FILEBROWSER SORTBY) |of| BROWSER)) (MYDATA (|fetch| TIDATA |of| FILE)) (NOSUBDIRS (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER)) OTHERDATA NEXTITEM PREVITEM N) (SETQ NEXTITEM (TB.FIND.ITEM TBROWSER (FUNCTION (LAMBDA (BROWSER ITEM) (AND (NOT (|fetch| TIUNSELECTABLE |of| ITEM)) (CL:FUNCALL FBSORTFN FILE ITEM)))))) (COND ((AND NEXTITEM (NOT NOSUBDIRS) (NEQ (SETQ N (|fetch| TI# |of| NEXTITEM)) 1) (|fetch| TIUNSELECTABLE |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))) (NOT (EQ.DIRECTORYP MYDATA (|fetch| TIDATA |of| NEXTITEM)))) (* |;;| "We sort before NEXTITEM, but it's preceded by a subdirectory line that isn't ours, so insert in front of the subdirectory") (SETQ NEXTITEM PREVITEM))) (TB.INSERT.ITEM TBROWSER FILE NEXTITEM) (COND (NOSUBDIRS) ((AND NEXTITEM (NOT (|fetch| TIUNSELECTABLE |of| NEXTITEM)) (EQ.DIRECTORYP MYDATA (SETQ OTHERDATA (|fetch| TIDATA |of| NEXTITEM)))) (* |;;| "All ok -- next item is not a subdirectory line, and its subdir is the same as mine, so I must be properly qualified already") ) (T (* |;;|  "Inserted at end, or newly inserted item has different subdirectory from the item that follows it") (COND ((AND NEXTITEM (NOT (|fetch| TIUNSELECTABLE |of| NEXTITEM))) (* \;  "Need subdirectory id in front of next file") (FB.INSERT.DIRECTORY TBROWSER BROWSER OTHERDATA NEXTITEM))) (COND ((COND ((EQ (SETQ N (|fetch| TI# |of| FILE)) 1) (* \;  "Inserted at front, needs qualification if it has a subdir") (NOT (NULL.DIRECTORYP MYDATA))) (T (NOT (EQ.DIRECTORYP MYDATA (|fetch| TIDATA |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))))))) (* \;  "Need id in front of new file as well") (FB.INSERT.DIRECTORY TBROWSER BROWSER MYDATA FILE))))) (FB.COUNT.FILE.CHANGE BROWSER FILE 'ADD)))) (FB.ANALYZE.PATTERN (LAMBDA (BROWSER SAMPLE) (* \; "Edited 6-Apr-90 20:00 by NM") (* |;;;| "Figures out what the 'real pattern' is from SAMPLE, one of the files that is claimed to match the pattern. Sets the NAMESTART field to where the pattern ends and the distinguishable names start. Also resets PATTERN to be the canonicalized pattern") (PROG ((PATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER)) (SAMPLEHOSTEND 0) PATHOSTEND LASTPATDIR STARTOFNAME) (|do| (* \; "Find end of sample's host name") (SELCHARQ (NTHCHARCODE SAMPLE (|add| SAMPLEHOSTEND 1)) (\' (|add| SAMPLEHOSTEND 1)) (} (* \; "End of directory") (RETURN)) (NIL (* \;  "End of file name without end of brace?") (RETURN (SETQ SAMPLEHOSTEND 0))) NIL)) RETRY (SETQ PATHOSTEND 0) (|do| (SELCHARQ (NTHCHARCODE PATTERN (|add| PATHOSTEND 1)) (\' (|add| PATHOSTEND 1)) (} (* \;  "End of directory, now look for end of matchable pattern") (RETURN (|for| (N _ PATHOSTEND) |do| (SELCHARQ (NTHCHARCODE PATTERN (|add| N 1)) (\' (|add| N 1)) ((\: < > /) (* \; "{DSK} and {UNIX} on Sun represent root directory in a form of \"{DSK}, or {x/n}<~> might become {x/n}jones>.") (OR (SELCHARQ (NTHCHARCODE SAMPLE (|add| SAMPLEHOSTEND 1)) ((< /) (* \;  "Good, there's a directory -- canonicalize it") (LET ((CANONICAL (DIRECTORYNAME (SUBSTRING PATTERN 1 (OR LASTPATDIR (SETQ LASTPATDIR PATHOSTEND)))) )) (AND CANONICAL (CONCAT CANONICAL (SUBSTRING PATTERN (ADD1 LASTPATDIR)))))) (PROGN (* \;  "File coming back has no directory, so there's nothing interesting to do") NIL)) PATTERN))) (FB.GETALLFILEINFO (LAMBDA (BROWSER GENERATOR ATTRIBUTES) (* \; "Edited 1-Feb-88 15:50 by bvm:") (* |;;| "Returns a FILEINFO field for the given attribute specs") (|for| ATTR |in| ATTRIBUTES |bind| VALUE TREESIZE |collect| (SETQ VALUE (\\GENERATEFILEINFO GENERATOR (CAR ATTR))) (|if| (AND (EQ VALUE 0) (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER) (FMEMB (CAR ATTR) '(SIZE LENGTH)) (SETQ TREESIZE (\\GENERATEFILEINFO GENERATOR 'SUBTREE.SIZE))) |then| (* |;;| "This is an NS directory node, so get its subtree size, which is much more interesting than size, which is always zero (directories have no data)") (SELECTQ (CAR ATTR) (SIZE (FOLDHI TREESIZE BYTESPERPAGE)) (LENGTH TREESIZE) (SHOULDNT)) |else| VALUE)))) ) (DEFINEQ (FB.SORT.VERSIONS (LAMBDA (ITEMS SORTFN) (* \; "Edited 25-Jan-88 15:22 by bvm") (* |;;;| "Sort ITEMS so that equal names are sorted by version according to SORTFN. Assumes that ITEMS are already sorted by name") (LET ((TAIL ITEMS) PREVTAIL NEXTTAIL NEWTAIL THISNAME) (|while| (CDR TAIL) |do| (COND ((STRING-EQUAL (SETQ THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| (CAR TAIL)))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| (CADR TAIL)))) (* \;  "Same name as next, so gather up all equal names") (SETQ NEXTTAIL (CDDR TAIL)) (|while| (AND NEXTTAIL (STRING-EQUAL THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME ) |of| (|fetch| TIDATA |of| (CAR NEXTTAIL))))) |do| (SETQ NEXTTAIL (CDR NEXTTAIL))) (SETQ NEWTAIL (SORT (|until| (EQ TAIL NEXTTAIL) |collect| (|pop| TAIL)) SORTFN)) (* \;  "Now splice NEWTAIL into list between PREVTAIL and NEXTTAIL") (COND (PREVTAIL (RPLACD PREVTAIL NEWTAIL)) (T (SETQ ITEMS NEWTAIL))) (COND ((SETQ TAIL NEXTTAIL) (RPLACD (SETQ PREVTAIL (LAST NEWTAIL)) NEXTTAIL)))) (T (SETQ TAIL (CDR (SETQ PREVTAIL TAIL)))))) ITEMS))) (FB.DECREASING.VERSION (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:53") (* |;;;| "Comparefn for sorting a group of same named files by decreasing version. Null version considered high") (AND (NOT (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| Y))))) (OR (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| X)))) (IGREATERP X Y))))) (FB.INCREASING.VERSION (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:55") (* |;;;| "Comparefn for sorting a group of same named files by increasing version. Null version considered high") (OR (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| Y)))) (AND (NOT (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| X))))) (ILESSP X Y))))) (FB.NAMES.DECREASING.VERSION (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:57") (* |;;;| "Comparison function for sorting file names in alphabetical order, decreasing versions") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ X (|fetch| TIDATA |of| X))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ Y (|fetch| TIDATA |of| Y))) UPPERCASEARRAY) (LESSP T) (EQUAL (AND (NOT (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| Y)) 0)) (OR (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| X))) (IGREATERP X Y)))) NIL))) (FB.NAMES.INCREASING.VERSION (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:54") (* |;;;| "Comparison function for sorting file names in alphabetical order, increasing versions") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ X (|fetch| TIDATA |of| X))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ Y (|fetch| TIDATA |of| Y))) UPPERCASEARRAY) (LESSP T) (EQUAL (OR (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| Y))) (AND (NOT (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| X)))) (ILESSP X Y)))) NIL))) (FB.DECREASING.NUMERIC.ATTR (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Comparison function for sorting file names in decreasing order of some numeric attribute. If values are equal, fall back on names decreasing version") (LET ((XVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) 0)) (YVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) 0))) (OR (IGREATERP XVAL YVAL) (AND (NOT (IGREATERP YVAL XVAL)) (FB.NAMES.DECREASING.VERSION X Y)))))) (FB.INCREASING.NUMERIC.ATTR (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Comparison function for sorting file names in increasing order of some numeric attribute. If values are equal, fall back on names decreasing version") (LET ((XVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) 0)) (YVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) 0))) (OR (ILESSP XVAL YVAL) (AND (NOT (ILESSP YVAL XVAL)) (FB.NAMES.DECREASING.VERSION X Y)))))) (FB.ALPHABETIC.ATTR (LAMBDA (X Y) (* |bvm:| "20-Oct-85 18:07") (* |;;;| "Comparison function for sorting file names in order of some textual attribute. If values are equal, fall back on names decreasing version") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) UPPERCASEARRAY) (LESSP T) (EQUAL (FB.NAMES.DECREASING.VERSION X Y)) NIL))) ) (DEFINEQ (FB.SORTCOMMAND (LAMBDA (BROWSER) (* \; "Edited 29-Jan-88 12:47 by bvm") (PROG ((TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (HADNOSUBDIRS (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER)) SORTATTR SORT# SORTFN REVERSED ALLFILES DATETYPE BYNAME) (COND ((NULL (SETQ SORTATTR (MENU (FB.GET.SORT.MENU BROWSER)))) (RETURN)) ((LISTP SORTATTR) (SETQ REVERSED T) (SETQ SORTATTR (CAR SORTATTR)))) (SETQ SORTFN (SELECTQ SORTATTR ((SIZE LENGTH BYTESIZE) (COND (REVERSED (FUNCTION FB.INCREASING.NUMERIC.ATTR)) (T (FUNCTION FB.DECREASING.NUMERIC.ATTR)))) ((CREATIONDATE WRITEDATE READDATE) (SETQ DATETYPE T) (COND (REVERSED (FUNCTION FB.INCREASING.NUMERIC.ATTR)) (T (FUNCTION FB.DECREASING.NUMERIC.ATTR)))) (NAME (SETQ BYNAME T) (COND (REVERSED (FUNCTION FB.NAMES.INCREASING.VERSION)) (T (FUNCTION FB.NAMES.DECREASING.VERSION)))) (FUNCTION FB.ALPHABETIC.ATTR))) (FB.PROMPTW.FORMAT BROWSER "Sorting by ~A..." SORTATTR) (SETQ ALLFILES (TB.COLLECT.ITEMS TBROWSER (FUNCTION FB.IS.NOT.SUBDIRECTORY.ITEM))) (COND ((NOT BYNAME) (* \;  "Need to compute the attribute on which we sort") (SETQ SORT# (OR (CL:POSITION SORTATTR (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER) :KEY (FUNCTION CAR)) (HELP "Couldn't find sort attribute" SORTATTR))) (|for| ITEM |in| ALLFILES |bind| (NAMESTART _ (AND (NOT HADNOSUBDIRS) (|fetch| (FILEBROWSER NAMESTART) |of| BROWSER))) DATA VALUE |do| (SETQ DATA (|fetch| TIDATA |of| ITEM)) (SETQ VALUE (CL:NTH SORT# (|fetch| (FBFILEDATA FILEINFO) |of| DATA))) (COND ((AND VALUE DATETYPE) (SETQ VALUE (IDATE VALUE)))) (|replace| (FBFILEDATA SORTVALUE) |of| DATA |with| VALUE) (COND ((AND NAMESTART (|fetch| (FBFILEDATA HASDIRPREFIX) |of| DATA)) (* \;  "Need to go back to 'full' names, since subdirectories are senseless when not sorted by name") (|replace| (FBFILEDATA STARTOFPNAME) |of| DATA |with| NAMESTART) (FB.CHECK.NAME.LENGTH BROWSER DATA))))) (HADNOSUBDIRS (* \;  "We're sorting by name, so switch back to print names without subdirs") (FB.SET.DEFAULT.NAME.WIDTH BROWSER) (|for| DATA |in| ALLFILES |do| (COND ((|fetch| (FBFILEDATA HASDIRPREFIX) |of| (SETQ DATA (|fetch| TIDATA |of| DATA))) (|replace| (FBFILEDATA STARTOFPNAME ) |of| DATA |with| (|fetch| (FBFILEDATA STARTOFNAME) |of| DATA)))) (FB.CHECK.NAME.LENGTH BROWSER DATA))) ) (SETQ ALLFILES (SORT ALLFILES SORTFN)) (COND ((EQ BYNAME HADNOSUBDIRS) (* \;  "Were wide names, now narrow, or vice versa") (FB.MAYBE.WIDEN.NAMES BROWSER))) (COND (BYNAME (FB.INSERT.SUBDIRECTORIES BROWSER ALLFILES))) (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (TB.REPLACE.ITEMS TBROWSER ALLFILES) (|replace| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER |with| (NOT BYNAME)) (|replace| (FILEBROWSER SORTBY) |of| BROWSER |with| SORTFN) (|replace| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER |with| (AND (NOT BYNAME) SORTATTR)) (|if| SORT# |then| (|replace| (FILEBROWSER SORTINDEX) |of| BROWSER |with| SORT#)) (|replace| (FILEBROWSER SORTBYDATE) |of| BROWSER |with| DATETYPE) (FB.PROMPTWPRINT BROWSER "done")))) (FB.INSERT.SUBDIRECTORIES (LAMBDA (BROWSER FILES) (* \; "Edited 26-Jan-88 10:45 by bvm") (|for| TAIL |on| FILES |bind| (LASTDATA _ (|create| FBFILEDATA SUBDIREND _ 0)) |when| (NOT (EQ.DIRECTORYP LASTDATA (SETQ LASTDATA (|fetch| TIDATA |of| (CAR TAIL))))) |do| (* \;  "This guy's directory differs from previous, so add subdirectory item") (ATTACH (FB.MAKE.SUBDIRECTORY.ITEM BROWSER LASTDATA) TAIL) (SETQ TAIL (CDR TAIL))))) (FB.GET.SORT.MENU (LAMBDA (BROWSER) (* \; "Edited 26-Jan-88 12:38 by bvm") (OR (|fetch| (FILEBROWSER SORTMENU) |of| BROWSER) (|replace| (FILEBROWSER SORTMENU) |of| BROWSER |with| (|create| MENU ITEMS _ (CONS '("Name" 'NAME "Sort files by name, decreasing version numbers" (SUBITEMS ("Decreasing version" 'NAME "Sort files by name, decreasing version numbers") ("Increasing version" '(NAME T) "Sort files by name, increasing version numbers"))) (|for| ATTR |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER ) |collect| `(,(SETQ ATTR (CAR ATTR)) ',ATTR "Sort by this attribute" ,(SELECTQ ATTR ((SIZE LENGTH BYTESIZE) `(SUBITEMS ("Decreasing" ',ATTR "Sort files in order of decreasing size" ) ("Increasing" '(,ATTR T) "Sort files in order of increasing size"))) ((CREATIONDATE WRITEDATE READDATE) `(SUBITEMS ("Newer first" ',ATTR "Sort files with newer dates appearing before older dates" ) ("Older first" '(,ATTR T) "Sort files with older dates appearing before newer dates" ))) NIL))))))))) ) (DEFINEQ (FB.EXPUNGECOMMAND (LAMBDA (FBROWSER KEY ITEM MENU CMD) (* \; "Edited 22-Feb-2021 12:36 by rmk:") (* \; "Edited 9-Apr-93 22:07 by jds") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER)) (NDELETED 0) FILES FILENAME FAILED FILE) (COND ((SETQ FILES (TB.COLLECT.ITEMS TBROWSER 'DELETED)) (FB.PROMPTWPRINT FBROWSER T "Expunging deleted files...") (FB.ALLOW.ABORT FBROWSER) (|for| ITEM |in| FILES |do| (COND ((DELFILE (SETQ FILENAME (FB.FETCHFILENAME ITEM))) (|add| NDELETED 1) (FB.REMOVE.FILE TBROWSER FBROWSER ITEM) (FB.UPDATE.COUNTERS FBROWSER 'BOTH)) (T (FB.PROMPTWPRINT FBROWSER T "Couldn't expunge " FILENAME) (SETQ FAILED T))) (* |;;|  "Let other things run (Like the mouse, so user can ABORT the expunge!)") (BLOCK)) (FB.PROMPTWPRINT FBROWSER (COND ((EQ NDELETED 0) " No") (T (CONCAT (COND (FAILED " Done, but only ") (T "done, ")) NDELETED))) " files expunged.") (COND (FAILED (COND (CMD (FB.PROMPTW.FORMAT FBROWSER " ~A aborted." CMD))) (RETURN NIL)))) (T (FB.PROMPTWPRINT FBROWSER T "No files were marked for deletion"))) (RETURN T)))) (FB.NEWPATTERNCOMMAND (LAMBDA (BROWSER) (* \; "Edited 28-Jan-88 01:11 by bvm") (LET (PATTERN) (COND ((AND (FB.MAYBE.EXPUNGE BROWSER "New Pattern") (SETQ PATTERN (FB.GET.NEWPATTERN BROWSER))) (FB.SETNEWPATTERN BROWSER PATTERN) (FB.UPDATEBROWSERITEMS BROWSER)))))) (FB.NEWINFOCOMMAND (LAMBDA (BROWSER) (* \; "Edited 22-Feb-2021 12:35 by rmk:") (* \; "Edited 30-Aug-94 19:47 by jds") (LET ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (INFOMENUW (|fetch| (FILEBROWSER INFOMENUW) |of| BROWSER)) REG) (COND ((NOT (OPENWP INFOMENUW)) (SETQ INFOMENUW (MENUWINDOW (|create| MENU ITEMS _ FB.INFO.MENU.ITEMS MENUROWS _ 2 TITLE _ "Info Options" CENTERFLG _ T MENUFONT _ FB.MENUFONT WHENSELECTEDFN _ (FUNCTION FB.INFOMENU.WHENSELECTEDFN)))) (ATTACHWINDOW INFOMENUW WINDOW 'BOTTOM 'JUSTIFY 'LOCALCLOSE) (COND ((LESSP (|fetch| (REGION BOTTOM) |of| (SETQ REG (WINDOWPROP INFOMENUW 'REGION))) 0) (* \;  "Bump whole window up on screen so we can see it") (MOVEW WINDOW (|create| POSITION XCOORD _ (|fetch| (REGION LEFT) |of| REG) YCOORD _ (|fetch| (REGION HEIGHT) |of| REG))))) (FB.INFOMENU.SHADEINITIALSELECTIONS INFOMENUW (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER)) (|replace| (FILEBROWSER INFOMENUW) |of| BROWSER |with| INFOMENUW) (WINDOWADDPROP INFOMENUW 'CLOSEFN (FUNCTION (LAMBDA (W) (AND (SETQ W (WINDOWPROP (MAINWINDOW W T) 'FILEBROWSER)) (|replace| (FILEBROWSER INFOMENUW) |of| W |with| NIL)))) T))) (FB.PROMPTWPRINT BROWSER 'CLEAR "Select from the lower menu which attributes are to be displayed, then click Recompute")))) (FB.DEPTHCOMMAND (LAMBDA (FBROWSER) (* \; "Edited 1-Feb-88 13:54 by bvm:") (LET ((OLDDEPTH (|fetch| (FILEBROWSER FBDEPTH) |of| FBROWSER)) NEWDEPTH) (FB.PROMPTWPRINT FBROWSER "Current depth is " (SELECTQ OLDDEPTH (NIL "global default") (T "infinite") OLDDEPTH) T "Specify new depth") (|if| (EQ (SETQ NEWDEPTH (MENU (|create| MENU ITEMS _ FB.DEPTH.MENU.ITEMS CENTERFLG _ T))) :NUMBER) |then| (FB.ALLOW.ABORT FBROWSER) (SETQ NEWDEPTH (RNUMBER "Enumeration Depth" NIL NIL NIL T NIL T))) (|if| (NULL NEWDEPTH) |then| (FB.PROMPTWPRINT FBROWSER T "Depth unchanged") |else| (FB.PROMPTWPRINT FBROWSER T "Depth set to " (SELECTQ NEWDEPTH (:GLOBAL (SETQ NEWDEPTH NIL ) "global default") (T "infinity") NEWDEPTH) " for future Recomputes") (|replace| (FILEBROWSER FBDEPTH) |of| FBROWSER |with| NEWDEPTH))))) (FB.SHAPECOMMAND (LAMBDA (BROWSER) (* \; "Edited 2-Feb-88 12:02 by bvm:") (* |;;| "Widen or narrow the browser so that all information is visible") (LET* ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (WREG (WINDOWREGION WINDOW)) (WWIDTH (|fetch| (REGION WIDTH) |of| WREG)) (EXTENT (WINDOWPROP WINDOW 'EXTENT)) EXCESSHEIGHT MENUW) (* |;;| "Add enough to the whole region width to compensate for the excess of the extent over the actual width, but don't get wider than the screen less a scroll bar. Using the EXTENT is not entirely correct--EXTENT's width reflects the widest line we have attempted to print, not the widest line we MIGHT print if window were scrolled to other items.") (|replace| (REGION WIDTH) |of| WREG |with| (SETQ WWIDTH (MIN (+ WWIDTH (- (|fetch| (REGION WIDTH) |of| EXTENT) (WINDOWPROP WINDOW 'WIDTH))) (- SCREENWIDTH SCROLLBARWIDTH)))) (|if| (AND (> (SETQ EXCESSHEIGHT (- (WINDOWPROP WINDOW 'HEIGHT) (|fetch| (REGION HEIGHT) |of| EXTENT))) 0) (SETQ MENUW (CDR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER )))) |then| (* \; "Window is also taller than it needs to be--shrink it back, though not smaller than the minimum height") (|replace| (REGION HEIGHT) |of| WREG |with| (MAX (- (|fetch| (REGION HEIGHT) |of| WREG) EXCESSHEIGHT) (+ (|fetch| (REGION HEIGHT) |of| (WINDOWPROP MENUW 'REGION)) (|fetch| (REGION HEIGHT) |of| (WINDOWPROP (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER) 'REGION))))) |else| (SETQ EXCESSHEIGHT NIL)) (|if| (> (|fetch| (REGION PRIGHT) |of| WREG) SCREENWIDTH) |then| (* \;  "If we're sticking over the edge on the right, move the region leftward.") (|replace| (REGION LEFT) |of| WREG |with| (- SCREENWIDTH WWIDTH))) (RESHAPEALLWINDOWS WINDOW WREG) (|if| EXCESSHEIGHT |then| (* \; "Silly reshaping routine tried to preserve the bottom, so scrolled the window up. Let's scroll it back down.") (SCROLLW WINDOW 0 (- EXCESSHEIGHT)))))) (FB.REMOVE.FILE (LAMBDA (TBROWSER FBROWSER ITEM) (* \; "Edited 25-Jan-88 17:24 by bvm") (* |;;;| "Removes ITEM from browser display, counts its removal") (LET ((N (|fetch| TI# |of| ITEM)) PREVITEM NEXTITEM NEXTNEXTITEM) (COND ((AND (NEQ N 1) (|fetch| TIUNSELECTABLE |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))) (OR (NULL (SETQ NEXTITEM (TB.NTH.ITEM TBROWSER (ADD1 N)))) (|fetch| TIUNSELECTABLE |of| NEXTITEM))) (* \;  "ITEM is between two subdirectory lines, so remove at least the preceding line") (TB.REMOVE.ITEM TBROWSER PREVITEM) (COND ((AND NEXTITEM (SETQ NEXTNEXTITEM (TB.NTH.ITEM TBROWSER (ADD1 N))) (COND ((EQ (|add| N -1) 1) (* |;;| "N decremented because of the remove above. Now removing first file, so see if next file has no subdir") (NULL.DIRECTORYP (|fetch| TIDATA |of| NEXTNEXTITEM))) (T (EQ.DIRECTORYP (|fetch| TIDATA |of| NEXTNEXTITEM) (|fetch| TIDATA |of| (TB.NTH.ITEM TBROWSER (SUB1 N))))))) (* |;;| "The next subdirectory line is superfluous, because the file after it and the file before us have the same subdirectory") (TB.REMOVE.ITEM TBROWSER NEXTITEM))))) (TB.REMOVE.ITEM TBROWSER ITEM) (FB.COUNT.FILE.CHANGE FBROWSER ITEM 'REMOVE)))) (FB.COUNT.FILE.CHANGE (LAMBDA (FBROWSER ITEM FLG) (* |bvm:| "13-Oct-85 17:47") (* |;;;| "Account for the addition or removal of ITEM from FBROWSER -- FLG is ADD or REMOVE") (LET ((SIGN (SELECTQ FLG (ADD 1) (REMOVE -1) (SHOULDNT))) (SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (DELETEDP (|fetch| TIDELETED |of| ITEM))) (|replace| (FILEBROWSER TOTALFILES) |of| FBROWSER |with| (|add| (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER) SIGN)) (COND (DELETEDP (|replace| (FILEBROWSER DELETEDFILES) |of| FBROWSER |with| (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) SIGN)))) (COND (SIZE (|add| (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) (SETQ SIZE (ITIMES SIZE SIGN))) (COND (DELETEDP (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) SIZE)))))))) (FB.SETNEWPATTERN (LAMBDA (FBROWSER PATTERN) (* \; "Edited 1-Feb-88 15:46 by bvm:") (* |;;| "Called to install a new PATTERN in a filebrowser. PATTERN should already have been passed thru DIRECTORY.FILL.PATTERN.") (LET (ICON) (|replace| (FILEBROWSER PATTERN) |of| FBROWSER |with| PATTERN) (|replace| (FILEBROWSER PREPAREDPATTERN) |of| FBROWSER |with| ( DIRECTORY.MATCH.SETUP PATTERN)) (|replace| (FILEBROWSER PATTERNPARSED?) |of| FBROWSER |with| NIL) (|replace| (FILEBROWSER NSPATTERN?) |of| FBROWSER |with| (STRPOS ":" (UNPACKFILENAME.STRING PATTERN 'HOST))) (COND ((SETQ ICON (WINDOWPROP (|fetch| (FILEBROWSER BROWSERWINDOW) |of| FBROWSER) 'ICONWINDOW)) (* \; "Change the icon label") (ICONW.TITLE ICON PATTERN))) PATTERN))) (FB.GET.NEWPATTERN (LAMBDA (BROWSER) (* \; "Edited 30-Aug-94 19:47 by jds") (FB.ALLOW.ABORT BROWSER) (LET* ((OLDPATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER)) (PATTERN (FB.PROMPTFORINPUT (COND (OLDPATTERN "New file group description: ") (T "File group description: ")) OLDPATTERN BROWSER T))) (COND (PATTERN (DIRECTORY.FILL.PATTERN PATTERN)))))) (FB.OPTIONSCOMMAND (LAMBDA (BROWSER) (* |bvm:| "13-Sep-85 16:13") (FB.PROMPTWPRINT BROWSER "Please use the Options roll-out submenu to select the option you desire."))) ) (* \; "window functions") (DEFINEQ (FB.INFOMENU.SHADEINITIALSELECTIONS (LAMBDA (MENUWINDOW INITIALSELECTIONS) (* \; "Edited 21-Jan-88 18:36 by bvm") (LET* ((MENU (CAR (WINDOWPROP MENUWINDOW 'MENU))) (MENUITEMS (|fetch| (MENU ITEMS) |of| MENU))) (|for| SELECTION |in| INITIALSELECTIONS |do| (SHADEITEM (FB.INFO.ITEM.NAMED SELECTION MENUITEMS) MENU FB.INFOSHADE MENUWINDOW))))) (FB.INFO.ITEM.NAMED (LAMBDA (TAG ITEMS) (* \; "Edited 21-Jan-88 17:38 by bvm") (* |;;;| "search list items for one with second element TAG") (|for| ITEM |in| ITEMS |when| (STRING-EQUAL (CADR ITEM) TAG) |do| (RETURN ITEM)))) ) (DEFINEQ (FB.MAKECOUNTERWINDOW (LAMBDA (BROWSERWINDOW FONT WIDTH HEIGHT TITLE) (* \; "Edited 22-Feb-2021 12:41 by rmk:") (* \; "Edited 30-Aug-94 19:47 by jds") (LET ((COUNTERW (CREATEW (|create| REGION LEFT _ 0 BOTTOM _ 0 HEIGHT _ HEIGHT WIDTH _ WIDTH) (OR TITLE "File Browser Window") NIL T))) (FB.MAKERIGIDWINDOW COUNTERW) (DSPFONT FONT COUNTERW) (ATTACHWINDOW COUNTERW BROWSERWINDOW 'TOP) (|replace| (FILEBROWSER COUNTERWINDOW) |of| (WINDOWPROP BROWSERWINDOW 'FILEBROWSER) |with| COUNTERW) (WINDOWPROP COUNTERW 'REPAINTFN (FUNCTION FB.COUNTERW.REDISPLAYFN)) (WINDOWPROP COUNTERW 'RESHAPEFN (FUNCTION FB.COUNTERW.REDISPLAYFN)) (WINDOWPROP COUNTERW 'PAGEFULLFN (FUNCTION NILL)) (* \;  "Set up for modernized window moving/shaping") (WINDOWPROP COUNTERW 'BUTTONEVENTFN (FUNCTION TOTOPW.MODERNIZE)) (WINDOWPROP BROWSERWINDOW 'TOPMARGIN 0) COUNTERW))) (FB.COUNTERW.REDISPLAYFN (LAMBDA (COUNTERWINDOW) (* \; "Edited 4-Feb-88 15:11 by bvm:") (LET ((BROWSER (WINDOWPROP (MAINWINDOW COUNTERWINDOW T) 'FILEBROWSER))) (|if| (|fetch| (FILEBROWSER FBREADY) |of| BROWSER) |then| (* \;  "Don't do this if user reshapes while we're still enumerating.") (CLEARW COUNTERWINDOW) (FB.DISPLAY.COUNTERS BROWSER))))) (FB.UPDATE.COUNTERS (LAMBDA (FBROWSER TYPE) (* \; "Edited 30-Aug-94 19:48 by jds") (LET* ((COUNTERW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| FBROWSER)) (XPOSPAIRS (|fetch| (FILEBROWSER COUNTERPOSITIONS) |of| FBROWSER)) (TOTAL (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER)) (TOTALPAGES (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER)) (DEL (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER)) (DELPAGES (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER)) (PAGESTRING (|fetch| (FILEBROWSER COUNTERPAGESTRING) |of| FBROWSER)) (HEIGHT (WINDOWPROP COUNTERW 'HEIGHT)) HERE LABELS) (SETQ LABELS (LIST (COND ((|fetch| (FILEBROWSER SHOWUNDELETED?) |of| FBROWSER) (FB.COUNTER.STRING FBROWSER (IDIFFERENCE TOTAL DEL) (IDIFFERENCE TOTALPAGES DELPAGES))) ((NEQ TYPE 'DELETED) (* \;  "Don't need to update total if only deleted count changed") (FB.COUNTER.STRING FBROWSER TOTAL TOTALPAGES))) (AND (NEQ TYPE 'TOTAL) (FB.COUNTER.STRING FBROWSER DEL DELPAGES)))) (DSPXPOSITION 0 COUNTERW) (|for| LAB |in| LABELS |as| PAIR |in| XPOSPAIRS |when| LAB |do| (DSPXPOSITION (CAR PAIR) COUNTERW) (PRIN3 LAB COUNTERW) (PRIN3 PAGESTRING COUNTERW) (BLTSHADE WHITESHADE COUNTERW (SETQ HERE (DSPXPOSITION NIL COUNTERW)) 0 (IDIFFERENCE (CADR PAIR) HERE) HEIGHT 'REPLACE))))) (FB.DISPLAY.COUNTERS (LAMBDA (FBROWSER) (* \; "Edited 30-Aug-94 19:48 by jds") (LET* ((COUNTERW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| FBROWSER)) (TOTAL (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER)) (TOTALPAGES (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER)) (DEL (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER)) (DELPAGES (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER)) (COUNTERWIDTH (WINDOWPROP COUNTERW 'WIDTH)) (COUNTERFONT (DSPFONT NIL COUNTERW)) (SECTIONWIDTH (IQUOTIENT COUNTERWIDTH 2)) (THRESHOLDWIDTH (IDIFFERENCE SECTIONWIDTH (ITIMES 2 (CHARWIDTH (CHARCODE \a) COUNTERFONT)))) (HEIGHT (WINDOWPROP COUNTERW 'HEIGHT)) PAGESTRING MAXWIDTH HERE LABELS) (SETQ LABELS (LIST (COND ((|fetch| (FILEBROWSER SHOWUNDELETED?) |of| FBROWSER) (LIST "Undeleted: " (FB.COUNTER.STRING FBROWSER (IDIFFERENCE TOTAL DEL) (IDIFFERENCE TOTALPAGES DELPAGES)))) (T (LIST "Total: " (FB.COUNTER.STRING FBROWSER TOTAL TOTALPAGES)) )) (LIST "Deleted: " (FB.COUNTER.STRING FBROWSER DEL DELPAGES)))) (DSPXPOSITION 0 COUNTERW) (DSPRIGHTMARGIN MAX.SMALLP COUNTERW) (LINELENGTH MAX.SMALLP COUNTERW) (SETQ MAXWIDTH 0) (|for| LAB |in| LABELS |do| (SETQ MAXWIDTH (IMAX MAXWIDTH (IPLUS (STRINGWIDTH (CAR LAB) COUNTERFONT) (STRINGWIDTH (CADR LAB) COUNTERFONT))))) (COND ((NOT (|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER)) (SETQ PAGESTRING "")) ((IGREATERP (PLUS MAXWIDTH (STRINGWIDTH (SETQ PAGESTRING " pages") COUNTERFONT)) THRESHOLDWIDTH) (* \; "Try a shorter word") (SETQ PAGESTRING " pgs"))) (COND ((IGREATERP (PLUS MAXWIDTH (STRINGWIDTH PAGESTRING COUNTERFONT)) THRESHOLDWIDTH) (* \;  "The long labels are too long, so abbreviate them. Only have to do this for very narrow windows") (|for| LAB |in| LABELS |do| (RPLACA LAB (CONCAT (SUBSTRING (CAR LAB) 1 3) ": "))))) (|replace| (FILEBROWSER COUNTERPOSITIONS) |of| FBROWSER |with| (|for| LAB |in| LABELS |as| NEXTPOS |from| SECTIONWIDTH |by| SECTIONWIDTH |collect| (PRIN3 (CAR LAB) COUNTERW) (LIST (DSPXPOSITION NIL COUNTERW) (PROGN (PRIN3 (CADR LAB) COUNTERW) (PRIN3 PAGESTRING COUNTERW) (BLTSHADE WHITESHADE COUNTERW (SETQ HERE (DSPXPOSITION NIL COUNTERW)) 0 (IDIFFERENCE NEXTPOS HERE) HEIGHT 'REPLACE) (DSPXPOSITION NEXTPOS COUNTERW) NEXTPOS)))) (|replace| (FILEBROWSER COUNTERPAGESTRING) |of| FBROWSER |with| PAGESTRING) ))) (FB.COUNTER.STRING (LAMBDA (FBROWSER NFILES NPAGES) (* |bvm:| "11-Sep-85 11:44") (COND ((|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER) (CONCAT NFILES " / " NPAGES)) (T (MKSTRING NFILES))))) ) (DEFINEQ (FB.MAKEHEADINGWINDOW (LAMBDA (BROWSERWINDOW WIDTH HEIGHT FONT) (* \; "Edited 22-Feb-2021 12:29 by rmk:") (* \; "Edited 22-Jan-88 17:45 by bvm") (LET ((HEADINGW (CREATEW (|create| REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ WIDTH HEIGHT _ HEIGHT) NIL 0 T))) (DSPFONT FONT HEADINGW) (FB.MAKERIGIDWINDOW HEADINGW) (ATTACHWINDOW HEADINGW BROWSERWINDOW 'TOP) (WINDOWPROP HEADINGW 'PASSTOMAINCOMS T) (* \;  "Pass ALL window ops to main window, since we look sort of like a title bar") (DSPTEXTURE BLACKSHADE HEADINGW) (WINDOWPROP HEADINGW 'REPAINTFN (FUNCTION FB.HEADINGW.REDISPLAYFN)) (WINDOWPROP HEADINGW 'RESHAPEFN (FUNCTION FB.HEADINGW.RESHAPEFN)) (* \;  "This is a white on black window") (DSPOPERATION 'INVERT HEADINGW) (DSPFILL NIL BLACKSHADE 'REPLACE HEADINGW) (* \;  "Set up for modernized window moving/shaping") (WINDOWPROP HEADINGW 'BUTTONEVENTFN (FUNCTION TOTOPW.MODERNIZE)) (WINDOWPROP BROWSERWINDOW 'TOPMARGIN 0) HEADINGW))) (FB.HEADINGW.REDISPLAYFN (LAMBDA (WINDOW) (* |bvm:| "19-Sep-85 14:39") (FB.HEADINGW.DISPLAY (WINDOWPROP (WINDOWPROP WINDOW 'MAINWINDOW) 'FILEBROWSER) WINDOW))) (FB.HEADINGW.RESHAPEFN (LAMBDA (WINDOW) (* \; "Edited 22-Jan-88 17:51 by bvm") (* |;;;| "Redraw the heading window after a reshape") (LET ((FBROWSER (WINDOWPROP (WINDOWPROP WINDOW 'MAINWINDOW) 'FILEBROWSER))) (CLEARW WINDOW) (FB.HEADINGW.DISPLAY FBROWSER WINDOW)))) (FB.HEADINGW.DISPLAY (LAMBDA (FBROWSER WINDOW) (* \; "Edited 30-Aug-94 19:42 by jds") (LET* ((STREAM (WINDOWPROP WINDOW 'DSP)) (CLIP (DSPCLIPPINGREGION NIL WINDOW)) (RMARG (|fetch| (REGION RIGHT) |of| CLIP)) (BORDER (WINDOWPROP (MAINWINDOW WINDOW) 'BORDER)) (NEXTPOS (+ BORDER (|fetch| (FILEBROWSER INFOSTART) |of| FBROWSER))) (DEPTH (|fetch| (FILEBROWSER FBDISPLAYEDDEPTH) |of| FBROWSER)) FORMAT) (DSPFILL CLIP BLACKSHADE 'REPLACE STREAM) (* \; "Note: title window has no border, so add the main window's border width to all x computations here.") (DSPRIGHTMARGIN 32000 STREAM) (|if| (< (|fetch| (REGION LEFT) |of| CLIP) NEXTPOS) |then| (* \;  "Some of \"Name (depth n)\" field may be visible.") (DSPXPOSITION (+ TB.LEFT.MARGIN BORDER) STREAM) (PRIN3 "Name" STREAM) (|if| (NEQ DEPTH 0) |then| (CL:FORMAT STREAM " (depth ~D)" DEPTH))) (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |until| (> NEXTPOS RMARG) |do| (DSPXPOSITION (|if| (LISTP (SETQ FORMAT (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC))) |then| (* \;  "Right-justified integer field, so right-justify title") (- (+ NEXTPOS (CADR FORMAT)) (STRINGWIDTH (|fetch| (INFOFIELD INFOLABEL) |of| SPEC) STREAM)) |else| NEXTPOS) STREAM) (PRIN3 (|fetch| (INFOFIELD INFOLABEL) |of| SPEC) STREAM) (|add| NEXTPOS (|fetch| (INFOFIELD INFOWIDTH) |of| SPEC)))))) ) (DEFINEQ (FB.ICONFN (LAMBDA (WINDOW OLDICON POSITION) (* \; "Edited 30-Aug-94 19:48 by jds") (OR OLDICON (TITLEDICONW FB.ICONSPEC (|fetch| (FILEBROWSER PATTERN) |of| (WINDOWPROP WINDOW 'FILEBROWSER)) FB.ICONFONT POSITION NIL NIL 'FILE)))) (FB.INFOMENU.WHENSELECTEDFN (LAMBDA (ITEM MENU KEY) (* |bvm:| "18-Sep-85 11:51") (LET* ((INFO (CADR ITEM)) (WINDOW (WINDOWPROP (WFROMMENU MENU) 'MAINWINDOW)) (BROWSER (WINDOWPROP WINDOW 'FILEBROWSER)) (CHOSEN (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER))) (COND ((FMEMB INFO CHOSEN) (SHADEITEM ITEM MENU WHITESHADE) (SETQ CHOSEN (REMOVE INFO CHOSEN))) (T (SHADEITEM ITEM MENU FB.INFOSHADE) (SETQ CHOSEN (CONS INFO CHOSEN)))) (|replace| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER |with| CHOSEN)))) (FB.CLOSEFN (LAMBDA (TBROWSER WINDOW FLG) (* \; "Edited 27-Jan-88 23:52 by bvm") (* |;;| "did you really want to close up shop?") (RESETLST (COND ((NOT (OBTAIN.MONITORLOCK (|fetch| (FILEBROWSER FBLOCK) |of| (TB.USERDATA TBROWSER)) T T)) (* \; "We're busy") (PROMPTPRINT (CONCAT "Can't " (L-CASE FLG) " window while browser is busy")) 'DON\'T) ((NEQ (TB.NUMBER.OF.ITEMS TBROWSER 'DELETED) 0) (* \;  "There are deleted items. Shall we expunge?") (SELECTQ (MENU (FB.EXPUNGE?.MENU)) (EXPUNGE (* \;  "Do expunge in another process, not here in mouse") (FUNCTION FB.CLOSE&EXPUNGE)) (NOEXPUNGE NIL) 'DON\'T)))))) (FB.EXPUNGE?.MENU (LAMBDA NIL (* \; "Edited 1-Feb-88 15:25 by bvm:") (OR FB.EXPUNGE?MENU (SETQ FB.EXPUNGE?MENU (|create| MENU ITEMS _ FB.CLOSE.MENU.ITEMS MENUROWS _ 2 CENTERFLG _ T TITLE _ "Do what with deleted files?" MENUFONT _ FB.BROWSERFONT))))) (FB.AFTERCLOSEFN (LAMBDA (TBROWSER WINDOW) (* |bvm:| "12-Sep-85 15:12") (* |;;;| "Snap circularities before window vanishes") (LET ((FBROWSER (WINDOWPROP WINDOW 'FILEBROWSER NIL))) (|replace| (FILEBROWSER TABLEBROWSER) |of| FBROWSER |with| NIL) (TB.USERDATA TBROWSER NIL)))) (FB.CLOSE&EXPUNGE (LAMBDA (TBROWSER WINDOW FLG) (* \; "Edited 1-Feb-88 16:37 by bvm:") (LET ((BROWSER (TB.USERDATA TBROWSER)) MENU ITEM) (|find| W |in| (ATTACHEDWINDOWS WINDOW) |suchthat| (AND (SETQ MENU (CAR (WINDOWPROP W 'MENU))) (EQ 1 (|fetch| (MENU MENUCOLUMNS) |of| MENU)))) (SETQ ITEM (ASSOC '|Expunge| (|fetch| (MENU ITEMS) |of| MENU))) (RESETLST (FB.MAKE.BROWSER.BUSY BROWSER ITEM MENU) (COND ((FB.EXPUNGECOMMAND BROWSER NIL NIL NIL FLG) (* |;;| "Expunge succeeded. Unshade the Expunge item and get rid of Abort before we shrink, or else they will still be shaded/Open when we expand") (FB.FINISH.COMMAND BROWSER ITEM MENU) (TB.FINISH.CLOSE TBROWSER (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER) FLG))))))) ) (DEFINEQ (FB.HARDCOPY.DIRECTORY (LAMBDA (WINDOW IMAGESTREAM) (* \; "Edited 30-Aug-94 19:42 by jds") (RESETLST (LET ((FBROWSER (WINDOWPROP WINDOW 'FILEBROWSER)) (TBROWSER (WINDOWPROP WINDOW 'TABLEBROWSER)) (SCALE (DSPSCALE NIL IMAGESTREAM)) (RMARG (DSPRIGHTMARGIN MAX.SMALLP IMAGESTREAM)) (LMARG (DSPLEFTMARGIN NIL IMAGESTREAM)) (MAXNAMEWIDTH 0) (MAINFONT FB.HARDCOPY.FONT) (DIRFONT (OR FB.HARDCOPY.DIRECTORY.FONT ITALICFONT)) FDATA INFO W LABEL COLUMNSPECS INFOLMARG PROPS FILES TITLE PAD DATEWIDTH) (ALLOW.BUTTON.EVENTS) (* \;  "Ensure that we are no longer the mouse process (should be redundant)") (FB.MAKE.BROWSER.BUSY FBROWSER) (* \;  "Grab the browser, so it doesn't change out from under us") (FB.ALLOW.ABORT FBROWSER) (* \; "Enable abort button") (FB.PROMPTWPRINT FBROWSER T "Producing hardcopy listing of directory...") (|if| MAINFONT |then| (* \;  "User-settable font for listing to appear in") (DSPFONT MAINFONT IMAGESTREAM)) (SETQ MAINFONT (DSPFONT NIL IMAGESTREAM)) (* \; "Get coerced font, or default") (SETQ TITLE (CONCAT "Directory of " (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER ))) (STREAMPROP IMAGESTREAM 'PRINTOPTIONS (LIST* 'DOCUMENT.NAME TITLE (STREAMPROP IMAGESTREAM 'PRINTOPTIONS))) (* \; "Give the document a nice name") (FB.HARDCOPY.PRINT.TITLE (CONCAT "Directory of " (WINDOWPROP (|fetch| (FILEBROWSER COUNTERWINDOW ) |of| FBROWSER) 'TITLE)) IMAGESTREAM LMARG RMARG) (|if| (|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER) |then| (FB.HARDCOPY.PRINT.TITLE (CONCAT (|fetch| (FILEBROWSER TOTALFILES ) |of| FBROWSER) " files in " (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) " pages") IMAGESTREAM LMARG RMARG)) (SETQ PAD (TIMES SCALE 12)) (* \; "Space between columns") (|for| ITEM |in| (SETQ FILES (TB.COLLECT.ITEMS TBROWSER)) |unless| (|fetch| (FBFILEDATA DIRECTORYP) |of| (SETQ FDATA (|fetch| TIDATA |of| ITEM))) |do| (SETQ MAXNAMEWIDTH (IMAX (STRINGWIDTH (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) MAINFONT) MAXNAMEWIDTH))) (SETQ COLUMNSPECS (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |as| INDEX |from| 0 |bind| PROTO |collect| (* \; "For each bit of info to print, compute how much space we expect it to need. Second slot filled in below") (LIST* (+ PAD (|if| (SETQ PROTO (|fetch| (INFOFIELD INFOPROTOTYPE) |of| SPEC)) |then| (STRINGWIDTH PROTO IMAGESTREAM) |elseif| (EQ (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC) 'DATE) |then| (OR DATEWIDTH (SETQ DATEWIDTH (FB.HARDCOPY.MAXWIDTH FILES INDEX MAINFONT T))) |else| (FB.HARDCOPY.MAXWIDTH FILES INDEX MAINFONT))) NIL SPEC))) (SETQ INFOLMARG (- RMARG (|for| PAIR |in| COLUMNSPECS |sum| (CAR PAIR)))) (LET ((NAMERIGHTMARG (+ LMARG MAXNAMEWIDTH PAD))) (|if| (< NAMERIGHTMARG INFOLMARG) |then| (* \;  "Enough space for name plus all info with room left over") (SETQ INFOLMARG NAMERIGHTMARG) |elseif| (> INFOLMARG LMARG) |then| (* \;  "Ok, there's enough space for info, though it might end up on a separate line from file name") |else| (* \;  "Ugh, want to print more info than fits on a line. Punt") (SETQ INFOLMARG NAMERIGHTMARG) (DSPRIGHTMARGIN RMARG IMAGESTREAM) (* \; "make it wrap after all"))) (LET ((FIRSTINFOCOLUMN INFOLMARG)) (|for| PAIR |in| COLUMNSPECS |do| (* \; "Print headers") (SETQ LABEL (|fetch| (INFOFIELD INFOLABEL) |of| (CDDR PAIR))) (SETQ W (FIXR (CAR PAIR))) (DSPXPOSITION (+ FIRSTINFOCOLUMN (IQUOTIENT (- (- W PAD) (STRINGWIDTH LABEL IMAGESTREAM) ) 2)) IMAGESTREAM) (* \; "Center the label") (PRIN3 LABEL IMAGESTREAM) (RPLACA PAIR (PROG1 FIRSTINFOCOLUMN (|add| FIRSTINFOCOLUMN W))) (* \;  "First element is left position of the entry ") (|if| (|fetch| (INFOFIELD INFOFORMAT) |of| (CDDR PAIR)) |then| (* \;  "Second element is right margin (for right-justified items)") (RPLACA (CDR PAIR) (- FIRSTINFOCOLUMN PAD)))) (TERPRI IMAGESTREAM) (TERPRI IMAGESTREAM)) (|for| ITEM |in| FILES |bind| FILEINFO INFO FORMAT HERE NEXT |do| (SETQ FDATA (|fetch| TIDATA |of| ITEM)) (|if| (|fetch| (FBFILEDATA DIRECTORYP) |of| FDATA) |then| (DSPFONT DIRFONT IMAGESTREAM) (DSPXPOSITION (+ LMARG (TIMES SCALE 16)) IMAGESTREAM) (PRIN3 (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) IMAGESTREAM) (DSPFONT MAINFONT IMAGESTREAM) |else| (PRIN3 (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) IMAGESTREAM) (|if| COLUMNSPECS |then| (SETQ FILEINFO (|fetch| (FBFILEDATA FILEINFO) |of| FDATA)) (|if| (AND (> (SETQ HERE (DSPXPOSITION NIL IMAGESTREAM)) INFOLMARG) (OR (NULL (SETQ NEXT (CADR (CAR COLUMNSPECS)))) (> HERE NEXT) (AND (SETQ INFO (CAR FILEINFO)) (> (+ HERE (TIMES SCALE 6)) (- NEXT (STRINGWIDTH INFO MAINFONT)))))) |then| (* \; "name overran start of info--go to next line. The complex second clause lets us cheat in the case where the first info column is right-justified and will turn out to be short enough to leave space") (TERPRI IMAGESTREAM)) (|for| PAIR |in| COLUMNSPECS |as| INFO |in| FILEINFO |do| (DSPXPOSITION (COND ((SETQ NEXT (CADR PAIR)) (* \;  "Get numbers to line up right justified") (- NEXT (STRINGWIDTH INFO MAINFONT))) (T (CAR PAIR))) IMAGESTREAM) (|if| INFO |then| (PRIN3 INFO IMAGESTREAM))))) (TERPRI IMAGESTREAM) (BLOCK)) (FB.PROMPTWPRINT FBROWSER "done") (DSPRIGHTMARGIN RMARG IMAGESTREAM))))) (FB.HARDCOPY.PRINT.TITLE (LAMBDA (TITLE IMAGESTREAM LMARG RMARG) (* \; "Edited 5-Mar-87 17:59 by bvm:") (DSPXPOSITION (+ LMARG (IQUOTIENT (- RMARG (+ LMARG (STRINGWIDTH TITLE IMAGESTREAM))) 2)) IMAGESTREAM) (|printout| IMAGESTREAM TITLE T T))) (FB.HARDCOPY.MAXWIDTH (LAMBDA (FILES ATTRINDEX FONT DATEP) (* \; "Edited 27-Jan-88 13:10 by bvm") (* |;;| "Compute maximum width of values of the ATTRIBUTE prop of each of the items in FILES.") (* |;;|  "If DATEP is true, we assume all dates are created equal, and just return the first one") (|if| (AND DATEP (NEQ (CHARWIDTH (CHARCODE W) FONT) (CHARWIDTH (CHARCODE \i) FONT))) |then| (* \;  "Variable-width font, let's compute it for real") (SETQ DATEP NIL)) (|for| ITEM |in| FILES |bind| (MAXWIDTH _ 0) INFO WIDTH |when| (AND (SETQ INFO (CL:NTH ATTRINDEX (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| ITEM)))) (> (SETQ WIDTH (STRINGWIDTH INFO FONT)) MAXWIDTH)) |do| (|if| DATEP |then| (RETURN WIDTH)) (SETQ MAXWIDTH WIDTH) |finally| (RETURN MAXWIDTH)))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) TABLEBROWSERDECLS) (DECLARE\: EVAL@COMPILE (RECORD INFOFIELD (INFONAME INFOLABEL INFOWIDTH INFOFORMAT INFOPROTOTYPE)) (DATATYPE FBFILEDATA ((FILENAME POINTER) (* \; "Full name of this file") (FILEINFO POINTER) (* \; "Plist of attributes") (VERSIONLESSNAME POINTER) (* \; "FILENAME sans version") (DIRECTORYP FLAG) (* \; "True if it's a directory line") (HASDIRPREFIX FLAG) (* \;  "True if it has a directory prefix beyond that in common to all the files") (DIRECTORYFILEP FLAG) (* \;  "True if the \"file\" in this item is actually a subdirectory") (SIZE POINTER) (* \; "Size of file, for stats") (FILEDEPTH BYTE) (* \;  "Number of levels of subdirectory beneath the main pattern--zero for files at that level") (SORTVALUE POINTER) (* \;  "Cached value by which we are sorting the dir.") (SUBDIREND WORD) (* \;  "Index of last char in subdirectory, or zero if HASDIRPREFIX is false") (STARTOFPNAME WORD) (* \;  "Start of name for printing purposes. Same as STARTOFNAME when browser sorted by name") (VERSION WORD) (* \; "Version, or zero if none") (STARTOFNAME WORD) (* \;  "Index beyond all directory fields") DUMMY) (ACCESSFNS FBFILEDATA ((PRINTNAME (SUBSTRING (FETCH (FBFILEDATA FILENAME ) OF DATUM) (FETCH (FBFILEDATA STARTOFPNAME ) OF DATUM))) (SUBDIRECTORY (SUBSTRING (FETCH (FBFILEDATA FILENAME) OF DATUM) 1 (FETCH (FBFILEDATA SUBDIREND ) OF DATUM)))))) (DATATYPE FILEBROWSER ((NOSUBDIRECTORIES FLAG) (* \;  "True if we don't want separate subdirectory lines -- subdirs then included in name") (NSPATTERN? FLAG) (* \; "True if host is an ns host") (SHOWUNDELETED? FLAG) (* \;  "True if counter window should show `Undeleted' rather than `Total' counts") (PATTERNPARSED? FLAG) (* \;  "True if PREPAREDPATTERN, NAMESTART, DIRECTORYSTART are valid") (SORTBYDATE FLAG) (* \;  "True if SORTATTRIBUTE is one of the date attributes") (FBREADY FLAG) (* \; "False while FB is enumerating.") (ABORTING FLAG) (* \;  "True if enumeration is being aborted") (FIXEDTITLE FLAG) (* \; "True if caller supplied title") (FBCOMPUTEDDEPTH BYTE) (* \;  "Depth at the time we enumerated directory (zero for infinite)") (FBDISPLAYEDDEPTH BYTE) (* \;  "Depth we are currently displaying (zero for infinite)") (TABLEBROWSER POINTER) (* \;  "Pointer to TABLEBROWSER object controlling the browser") (BROWSERWINDOW POINTER) (* \; "Main window") (COUNTERWINDOW POINTER) (* \;  "Window that counts files, pages, deletions") (HEADINGWINDOW POINTER) (* \;  "Window with headings for browser columns") (INFOMENUW POINTER) (* \;  "Window containing choices for info to be displayed, or NIL if none yet") (PROMPTWINDOW POINTER) (* \; "GETPROMPTWINDOW BROWSERWINDOW") (INFODISPLAYED POINTER) (* \;  "List of attribute specs to be displayed") (PATTERN POINTER) (* \;  "Directory pattern being enumerated") (PREPAREDPATTERN POINTER) (* \; "DIRECTORY.MATCH.SETUP of same") (SEEWINDOW POINTER) (* \;  "Primary window used by FAST SEE command") (BROWSERFONT POINTER) (* \; "Font of BROWSERWINDOW") (SORTBY POINTER) (* \;  "Sorting function or NIL for default sort") (NAMESTART WORD) (* \;  "Index of first character in file name beyond the common prefix shared by all") (DIRECTORYSTART WORD) (* \;  "Index of first character of directory in file names") (INFOSTART WORD) (* \;  "X position in browser where first col of info is displayed") (NAMEOVERHEAD WORD) (* \;  "This plus width of name gives is how much to allow before INFOSTART") (OVERFLOWSPACING WORD) (* \;  "Increment between sizes considered for INFOSTART") (DIGITWIDTH WORD) (TOTALFILES WORD) (* \;  "Total number of files, deleted files, pages, deleted pages at the moment") (DELETEDFILES WORD) (TOTALPAGES POINTER) (DELETEDPAGES POINTER) (PAGECOUNT? POINTER) (* \;  "True if INFOCHOICES includes SIZE or LENGTH, so that we can count pages") (COUNTERPOSITIONS POINTER) (* \;  "List of pairs (left right) describing regions where the values of the counters are displayed") (COUNTERPAGESTRING POINTER) (* \;  "String to print after file/page count") (OVERFLOWWIDTHS POINTER) (* \;  "List of (xpos occurrences) describing files whose names exceed default INFOSTART") (INFOMENUCHOICES POINTER) (* \;  "Selections user has made in Info window, not necessarily the info currently displayed") (UPDATEPROC POINTER) (* \;  "Process doing an Update (Recompute)") (DEFAULTDIR POINTER) (* \;  "Default directory for destination of Copy/Rename") (SORTATTRIBUTE POINTER) (* \;  "Attribute being sorted on, or NIL if by name") (SORTMENU POINTER) (FBLOCK POINTER) (* \;  "Lock acquired by filebrowser operations") (SORTINDEX WORD) (* \;  "Index (zero-based) in file info of the sort attribute") (SIZEINDEX WORD) (* \; "Index of size attribute") (FBDEPTH POINTER) (* \;  "Enumeration depth, or NIL for default") (ABORTWINDOW POINTER) (* \;  "Dotted pair of (abortwindow . menuw) for this browser's abort window.") DUMMY)) ) (/DECLAREDATATYPE 'FBFILEDATA '(POINTER POINTER POINTER FLAG FLAG FLAG POINTER BYTE POINTER WORD WORD WORD WORD POINTER) '((FBFILEDATA 0 POINTER) (FBFILEDATA 2 POINTER) (FBFILEDATA 4 POINTER) (FBFILEDATA 4 (FLAGBITS . 0)) (FBFILEDATA 4 (FLAGBITS . 16)) (FBFILEDATA 4 (FLAGBITS . 32)) (FBFILEDATA 6 POINTER) (FBFILEDATA 8 (BITS . 7)) (FBFILEDATA 10 POINTER) (FBFILEDATA 9 (BITS . 15)) (FBFILEDATA 12 (BITS . 15)) (FBFILEDATA 13 (BITS . 15)) (FBFILEDATA 14 (BITS . 15)) (FBFILEDATA 16 POINTER)) '18) (/DECLAREDATATYPE 'FILEBROWSER '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG BYTE BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER) '((FILEBROWSER 0 (FLAGBITS . 0)) (FILEBROWSER 0 (FLAGBITS . 16)) (FILEBROWSER 0 (FLAGBITS . 32)) (FILEBROWSER 0 (FLAGBITS . 48)) (FILEBROWSER 0 (FLAGBITS . 64)) (FILEBROWSER 0 (FLAGBITS . 80)) (FILEBROWSER 0 (FLAGBITS . 96)) (FILEBROWSER 0 (FLAGBITS . 112)) (FILEBROWSER 0 (BITS . 135)) (FILEBROWSER 1 (BITS . 7)) (FILEBROWSER 2 POINTER) (FILEBROWSER 4 POINTER) (FILEBROWSER 6 POINTER) (FILEBROWSER 8 POINTER) (FILEBROWSER 10 POINTER) (FILEBROWSER 12 POINTER) (FILEBROWSER 14 POINTER) (FILEBROWSER 16 POINTER) (FILEBROWSER 18 POINTER) (FILEBROWSER 20 POINTER) (FILEBROWSER 22 POINTER) (FILEBROWSER 24 POINTER) (FILEBROWSER 26 (BITS . 15)) (FILEBROWSER 27 (BITS . 15)) (FILEBROWSER 28 (BITS . 15)) (FILEBROWSER 29 (BITS . 15)) (FILEBROWSER 30 (BITS . 15)) (FILEBROWSER 31 (BITS . 15)) (FILEBROWSER 32 (BITS . 15)) (FILEBROWSER 33 (BITS . 15)) (FILEBROWSER 34 POINTER) (FILEBROWSER 36 POINTER) (FILEBROWSER 38 POINTER) (FILEBROWSER 40 POINTER) (FILEBROWSER 42 POINTER) (FILEBROWSER 44 POINTER) (FILEBROWSER 46 POINTER) (FILEBROWSER 48 POINTER) (FILEBROWSER 50 POINTER) (FILEBROWSER 52 POINTER) (FILEBROWSER 54 POINTER) (FILEBROWSER 56 POINTER) (FILEBROWSER 58 (BITS . 15)) (FILEBROWSER 59 (BITS . 15)) (FILEBROWSER 60 POINTER) (FILEBROWSER 62 POINTER) (FILEBROWSER 64 POINTER)) '66) (DECLARE\: EVAL@COMPILE (RPAQQ FB.MORE.BORDER 8) (RPAQQ FB.NULL.VERSION 0) (CONSTANTS FB.MORE.BORDER FB.NULL.VERSION) ) (DECLARE\: EVAL@COMPILE (PUTPROPS NULL.VERSIONP MACRO ((V) (EQ V 0))) (PUTPROPS NULL.DIRECTORYP MACRO ((FILEDATA) (EQ (FETCH (FBFILEDATA SUBDIREND) OF FILEDATA) 0))) (PUTPROPS EQ.DIRECTORYP MACRO (OPENLAMBDA (FD1 FD2) (STRING-EQUAL (|fetch| (FBFILEDATA FILENAME) |of| FD1) (|fetch| (FBFILEDATA FILENAME) |of| FD2) :END1 (|fetch| (FBFILEDATA SUBDIREND) |of| FD1) :END2 (|fetch| (FBFILEDATA SUBDIREND) |of| FD2)))) (PUTPROPS NULL.FIELDP MACRO (OPENLAMBDA (STR) (OR (NULL STR) (EQ (NCHARS STR) 0)))) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FB.ICONFONT FB.BROWSERFONT FB.PROMPTFONT FB.MENUFONT FB.HARDCOPY.FONT FB.HARDCOPY.DIRECTORY.FONT FB.EXPUNGE?MENU FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.MENU.ITEMS FB.DEFAULT.INFO FB.INFOSHADE FB.INFO.MENU.ITEMS FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE DIRCOMMANDS FB.PROMPTLINES FB.INFO.FIELDS |WindowTitleDisplayStream| FB.ICONSPEC FB.DEFAULT.NAME.WIDTH FB.OVERFLOW.MAXABSOLUTE FB.OVERFLOW.MAXFRAC FB.DEFAULT.EDITOR FB.BROWSER.DIRECTORY.FONT ITALICFONT PRINTFILETYPES) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (/DECLAREDATATYPE 'FILEBROWSER '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG BYTE BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER) '((FILEBROWSER 0 (FLAGBITS . 0)) (FILEBROWSER 0 (FLAGBITS . 16)) (FILEBROWSER 0 (FLAGBITS . 32)) (FILEBROWSER 0 (FLAGBITS . 48)) (FILEBROWSER 0 (FLAGBITS . 64)) (FILEBROWSER 0 (FLAGBITS . 80)) (FILEBROWSER 0 (FLAGBITS . 96)) (FILEBROWSER 0 (FLAGBITS . 112)) (FILEBROWSER 0 (BITS . 135)) (FILEBROWSER 1 (BITS . 7)) (FILEBROWSER 2 POINTER) (FILEBROWSER 4 POINTER) (FILEBROWSER 6 POINTER) (FILEBROWSER 8 POINTER) (FILEBROWSER 10 POINTER) (FILEBROWSER 12 POINTER) (FILEBROWSER 14 POINTER) (FILEBROWSER 16 POINTER) (FILEBROWSER 18 POINTER) (FILEBROWSER 20 POINTER) (FILEBROWSER 22 POINTER) (FILEBROWSER 24 POINTER) (FILEBROWSER 26 (BITS . 15)) (FILEBROWSER 27 (BITS . 15)) (FILEBROWSER 28 (BITS . 15)) (FILEBROWSER 29 (BITS . 15)) (FILEBROWSER 30 (BITS . 15)) (FILEBROWSER 31 (BITS . 15)) (FILEBROWSER 32 (BITS . 15)) (FILEBROWSER 33 (BITS . 15)) (FILEBROWSER 34 POINTER) (FILEBROWSER 36 POINTER) (FILEBROWSER 38 POINTER) (FILEBROWSER 40 POINTER) (FILEBROWSER 42 POINTER) (FILEBROWSER 44 POINTER) (FILEBROWSER 46 POINTER) (FILEBROWSER 48 POINTER) (FILEBROWSER 50 POINTER) (FILEBROWSER 52 POINTER) (FILEBROWSER 54 POINTER) (FILEBROWSER 56 POINTER) (FILEBROWSER 58 (BITS . 15)) (FILEBROWSER 59 (BITS . 15)) (FILEBROWSER 60 POINTER) (FILEBROWSER 62 POINTER) (FILEBROWSER 64 POINTER)) '66) (/DECLAREDATATYPE 'FBFILEDATA '(POINTER POINTER POINTER FLAG FLAG FLAG POINTER BYTE POINTER WORD WORD WORD WORD POINTER) '((FBFILEDATA 0 POINTER) (FBFILEDATA 2 POINTER) (FBFILEDATA 4 POINTER) (FBFILEDATA 4 (FLAGBITS . 0)) (FBFILEDATA 4 (FLAGBITS . 16)) (FBFILEDATA 4 (FLAGBITS . 32)) (FBFILEDATA 6 POINTER) (FBFILEDATA 8 (BITS . 7)) (FBFILEDATA 10 POINTER) (FBFILEDATA 9 (BITS . 15)) (FBFILEDATA 12 (BITS . 15)) (FBFILEDATA 13 (BITS . 15)) (FBFILEDATA 14 (BITS . 15)) (FBFILEDATA 16 POINTER)) '18) (ADDTOVAR SYSTEMRECLST (DATATYPE FILEBROWSER ((NOSUBDIRECTORIES FLAG) (NSPATTERN? FLAG) (SHOWUNDELETED? FLAG) (PATTERNPARSED? FLAG) (SORTBYDATE FLAG) (FBREADY FLAG) (ABORTING FLAG) (FIXEDTITLE FLAG) (FBCOMPUTEDDEPTH BYTE) (FBDISPLAYEDDEPTH BYTE) (TABLEBROWSER POINTER) (BROWSERWINDOW POINTER) (COUNTERWINDOW POINTER) (HEADINGWINDOW POINTER) (INFOMENUW POINTER) (PROMPTWINDOW POINTER) (INFODISPLAYED POINTER) (PATTERN POINTER) (PREPAREDPATTERN POINTER) (SEEWINDOW POINTER) (BROWSERFONT POINTER) (SORTBY POINTER) (NAMESTART WORD) (DIRECTORYSTART WORD) (INFOSTART WORD) (NAMEOVERHEAD WORD) (OVERFLOWSPACING WORD) (DIGITWIDTH WORD) (TOTALFILES WORD) (DELETEDFILES WORD) (TOTALPAGES POINTER) (DELETEDPAGES POINTER) (PAGECOUNT? POINTER) (COUNTERPOSITIONS POINTER) (COUNTERPAGESTRING POINTER) (OVERFLOWWIDTHS POINTER) (INFOMENUCHOICES POINTER) (UPDATEPROC POINTER) (DEFAULTDIR POINTER) (SORTATTRIBUTE POINTER) (SORTMENU POINTER) (FBLOCK POINTER) (SORTINDEX WORD) (SIZEINDEX WORD) (FBDEPTH POINTER) (ABORTWINDOW POINTER) DUMMY)) (DATATYPE FBFILEDATA ((FILENAME POINTER) (FILEINFO POINTER) (VERSIONLESSNAME POINTER) (DIRECTORYP FLAG) (HASDIRPREFIX FLAG) (DIRECTORYFILEP FLAG) (SIZE POINTER) (FILEDEPTH BYTE) (SORTVALUE POINTER) (SUBDIREND WORD) (STARTOFPNAME WORD) (VERSION WORD) (STARTOFNAME WORD) DUMMY)) ) (DECLARE\: DONTEVAL@LOAD DOCOPY (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T) (ADDTOVAR *ATTACHED-WINDOW-COMMAND-SYNONYMS* (HARDCOPYIMAGEW.TOFILE . HARDCOPYIMAGEW) (HARDCOPYIMAGEW.TOPRINTER . HARDCOPYIMAGEW)) (ADDTOVAR |BackgroundMenuCommands| ("FileBrowser" '(FILEBROWSER) "Opens a filebrowser window; prompts for pattern")) (RPAQQ |BackgroundMenu| NIL) ) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA FB) (ADDTOVAR NLAML ) (ADDTOVAR LAMA FB.PROMPTW.FORMAT FB.PROMPTWPRINT) ) (PUTPROPS FILEBROWSER COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1993 1994 1999 2000 2001 2021)) (DECLARE\: DONTCOPY (FILEMAP (NIL (28186 50822 (FB 28196 . 29152) (FB.COPYBINARYCOMMAND 29154 . 29500) (FB.COPYTEXTCOMMAND 29502 . 29844) (FILEBROWSER 29846 . 42952) (FB.TABLEBROWSER 42954 . 43171) (FB.SELECTEDFILES 43173 . 43810) (FB.FETCHFILENAME 43812 . 44204) (FB.DIRECTORYP 44206 . 44534) (FB.PROMPTWPRINT 44536 . 45582) (FB.PROMPTW.FORMAT 45584 . 46321) (FB.PROMPTFORINPUT 46323 . 48575) (FB.YES-OR-NO-P 48577 . 49611) ( FB.ALLOW.ABORT 49613 . 50467) (\\FB.HARDCOPY.TOFILE.EXTENSION 50469 . 50820)) (50846 51799 (FB.STARTUP 50856 . 51371) (FB.MAKERIGIDWINDOW 51373 . 51797)) (51800 57172 (FB.PRINTFN 51810 . 56963) (FB.COPYFN 56965 . 57170)) (57222 63264 (FB.MENU.WHENSELECTEDFN 57232 . 57590) (FB.COMMANDSELECTEDFN 57592 . 59131) (FB.SUBITEMP 59133 . 59568) (FB.MAKE.BROWSER.BUSY 59570 . 60308) (FB.FINISH.COMMAND 60310 . 62275) (FB.HANDLE.ABORT.BUTTON 62277 . 63262)) (63265 68781 (FB.DELETECOMMAND 63275 . 63556) ( FB.DELVERCOMMAND 63558 . 66751) (FB.IS.NOT.SUBDIRECTORY.ITEM 66753 . 66934) (FB.DELVER.FILES 66936 . 68025) (FB.DELETE.FILE 68027 . 68779)) (68782 70107 (FB.UNDELETECOMMAND 68792 . 69077) ( FB.UNDELETEALLCOMMAND 69079 . 69358) (FB.UNDELETE.FILE 69360 . 70105)) (70108 94289 (FB.COPYCOMMAND 70118 . 70387) (FB.RENAMECOMMAND 70389 . 70664) (FB.COPY/RENAME.COMMAND 70666 . 71589) ( FB.COPY/RENAME.ONE 71591 . 73913) (FB.COPY/RENAME.MANY 73915 . 80135) (FB.MERGE.DIRECTORIES 80137 . 80555) (FB.GREATEST.PREFIX 80557 . 81913) (FB.MAYBE.INSERT.FILE 81915 . 89355) (FB.GET.NEW.FILE.SPEC 89357 . 93188) (FB.CANONICAL.DIRECTORY 93190 . 94287)) (94290 102074 (FB.HARDCOPYCOMMAND 94300 . 95430 ) (FB.HARDCOPY.TOFILE 95432 . 102072)) (102075 113638 (FB.EDITCOMMAND 102085 . 102886) ( FB.EDITCOMMAND.ONEFILE 102888 . 107854) (FB.EDITLISPFILE 107856 . 108895) (FB.BROWSECOMMAND 108897 . 113636)) (113639 125432 (FB.FASTSEECOMMAND 113649 . 117099) (FB.FASTSEE.ONEFILE 117101 . 120130) ( FB.SEEFULLFN 120132 . 124263) (FB.SEEBUTTONFN 124265 . 125430)) (125433 127179 (FB.LOADCOMMAND 125443 . 125950) (FB.COMPILECOMMAND 125952 . 126490) (FB.OPERATE.ON.FILES 126492 . 127177)) (127180 174229 ( FB.UPDATECOMMAND 127190 . 127415) (FB.MAYBE.EXPUNGE 127417 . 128412) (FB.UPDATEBROWSERITEMS 128414 . 141629) (FB.DATE 141631 . 142372) (FB.ADJUST.DATE.WIDTH 142374 . 145342) (FB.SET.BROWSER.TITLE 145344 . 146201) (FB.MAYBE.WIDEN.NAMES 146203 . 148322) (FB.SET.DEFAULT.NAME.WIDTH 148324 . 149688) ( FB.CREATE.FILEBUCKET 149690 . 156910) (FB.CHECK.NAME.LENGTH 156912 . 159333) (FB.ADD.FILEGROUP 159335 . 160862) (FB.INSERT.DIRECTORY 160864 . 161102) (FB.MAKE.SUBDIRECTORY.ITEM 161104 . 162513) ( FB.ADD.FILE 162515 . 163128) (FB.INSERT.FILE 163130 . 166542) (FB.ANALYZE.PATTERN 166544 . 171808) ( FB.CANONICALIZE.PATTERN 171810 . 173122) (FB.GETALLFILEINFO 173124 . 174227)) (174230 182389 ( FB.SORT.VERSIONS 174240 . 177011) (FB.DECREASING.VERSION 177013 . 177682) (FB.INCREASING.VERSION 177684 . 178305) (FB.NAMES.DECREASING.VERSION 178307 . 179342) (FB.NAMES.INCREASING.VERSION 179344 . 180341) (FB.DECREASING.NUMERIC.ATTR 180343 . 181023) (FB.INCREASING.NUMERIC.ATTR 181025 . 181699) ( FB.ALPHABETIC.ATTR 181701 . 182387)) (182390 192232 (FB.SORTCOMMAND 182400 . 189230) ( FB.INSERT.SUBDIRECTORIES 189232 . 190029) (FB.GET.SORT.MENU 190031 . 192230)) (192233 208322 ( FB.EXPUNGECOMMAND 192243 . 194762) (FB.NEWPATTERNCOMMAND 194764 . 195162) (FB.NEWINFOCOMMAND 195164 . 197930) (FB.DEPTHCOMMAND 197932 . 199707) (FB.SHAPECOMMAND 199709 . 203051) (FB.REMOVE.FILE 203053 . 204874) (FB.COUNT.FILE.CHANGE 204876 . 206321) (FB.SETNEWPATTERN 206323 . 207493) (FB.GET.NEWPATTERN 207495 . 208079) (FB.OPTIONSCOMMAND 208081 . 208320)) (208357 209369 ( FB.INFOMENU.SHADEINITIALSELECTIONS 208367 . 209014) (FB.INFO.ITEM.NAMED 209016 . 209367)) (209370 218836 (FB.MAKECOUNTERWINDOW 209380 . 210842) (FB.COUNTERW.REDISPLAYFN 210844 . 211431) ( FB.UPDATE.COUNTERS 211433 . 213505) (FB.DISPLAY.COUNTERS 213507 . 218567) (FB.COUNTER.STRING 218569 . 218834)) (218837 223480 (FB.MAKEHEADINGWINDOW 218847 . 220395) (FB.HEADINGW.REDISPLAYFN 220397 . 220663) (FB.HEADINGW.RESHAPEFN 220665 . 221041) (FB.HEADINGW.DISPLAY 221043 . 223478)) (223481 227664 (FB.ICONFN 223491 . 223838) (FB.INFOMENU.WHENSELECTEDFN 223840 . 224570) (FB.CLOSEFN 224572 . 225775) (FB.EXPUNGE?.MENU 225777 . 226189) (FB.AFTERCLOSEFN 226191 . 226552) (FB.CLOSE&EXPUNGE 226554 . 227662 )) (227665 239723 (FB.HARDCOPY.DIRECTORY 227675 . 238032) (FB.HARDCOPY.PRINT.TITLE 238034 . 238360) ( FB.HARDCOPY.MAXWIDTH 238362 . 239721))))) STOP \ No newline at end of file diff --git a/library/FILEBROWSER.LCOM b/library/FILEBROWSER.LCOM index 25db45b4..444d474d 100644 Binary files a/library/FILEBROWSER.LCOM and b/library/FILEBROWSER.LCOM differ diff --git a/lispusers/COMPAREDIRECTORIES b/lispusers/COMPAREDIRECTORIES index d204ff9e..169007cd 100644 --- a/lispusers/COMPAREDIRECTORIES +++ b/lispusers/COMPAREDIRECTORIES @@ -1 +1 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 7-Jan-2021 23:21:40"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;275 63412 changes to%: (FNS COMPAREDIRECTORIES) previous date%: "31-Oct-2020 09:13:05" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;274) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990, 1994, 1998, 2018, 2020, 2021 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COMPAREDIRECTORIESCOMS) (RPAQQ COMPAREDIRECTORIESCOMS ( (* ;; "Compare the contents of two directories.") (FNS COMPAREDIRECTORIES CDFILES COMPAREDIRECTORIES.INFOS MATCHNAME) (FNS CDPRINT CDPRINT.LINE) (FNS CDMAP CDENTRY CDSUBSET) (FNS BINCOMP EOLTYPE) (RECORDS CDENTRY CDINFO) (* ;; "look for compiled files older than the sources") (FNS FIND-UNCOMPILED-FILES FIND-UNSOURCED-FILES FIND-SOURCE-FILES FIND-COMPILED-FILES FIND-UNLOADED-FILES FIND-LOADED-FILES FIND-MULTICOMPILED-FILES) (FNS CREATED-AS SOURCE-FOR-COMPILED-P COMPILE-SOURCE-DATE-DIFF) (FNS FIX-DIRECTORY-DATES FIX-EQUIV-DATES COPY-COMPARED-FILES COPY-MISSING-FILES COMPILED-ON-SAME-SOURCE) [VARS (ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"] (INITVARS (LASTCDENTRIES NIL)) (COMS (FNS COMPARE-ENTRY-SOURCE-FILES) (FILES COMPARESOURCES)))) (* ;; "Compare the contents of two directories.") (DEFINEQ (COMPAREDIRECTORIES [LAMBDA (DIR1 DIR2 SELECT FILEPATTERNS EXTENSIONSTOAVOID USEDIRECTORYDATE OUTPUTFILE ALLVERSIONS) (* ; "Edited 7-Jan-2021 23:21 by rmk:") (* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on DIR1 and DIR2, listing which is newer, or when one is not found on the other. If SELECT is or contains SAME/=, BEFORE/<, AFTER/>, then files where DIR1 is the same as, earlier than, or later than DIR2 are selected. SELECT= NIL is the same as (< >), T is the same as (< > =). Also allows selection based on file-length criteria.") (* ;; "") (* ;; "Unless USEDIRECTORYDATE, comparison is with respect to the the LISP filecreated dates if evailable.") (* ;; "") (* ;; "If OUTPUTFILE is NIL, the list of compared entries is returned. Otherwise the selected entries are printed on OUTPUTFILE (T for the display).") [SETQ SELECT (SELECTQ SELECT (NIL '(< > -* *-)) (T '(< > -* *- =)) (FOR S IN (MKLIST SELECT) COLLECT (SELECTQ S ((AFTER >) '>) ((BEFORE <) '<) ((SAME SAMEDATE =) '=) (AUTHOR 'AUTHOR) (-* '-*) (*- '*-) (~= '~=) (ERROR "UNRECOGNIZED SELECT PARAMETER" S] (PROG (INFOS1 INFOS2 CANDIDATES SELECTED COMPAREDATE DEPTH1 DEPTH2) [SETQ COMPAREDATE (INTERSECTION SELECT '(< > =] (* ;; "DIRECTORYNAME here to get unrelativized specifications for header.") (* ;; "Allow all subdirectories if a directory ends in *, but peel it off for the resolution") (CL:WHEN (EQ '* (NTHCHAR DIR1 -1)) (SETQ DEPTH1 T) (SETQ DIR1 (SUBSTRING DIR1 1 -2))) (CL:WHEN (EQ '* (NTHCHAR DIR2 -1)) (SETQ DEPTH2 T) (SETQ DIR2 (SUBSTRING DIR2 1 -2))) (SETQ DIR1 (OR (DIRECTORYNAME (OR DIR1 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR1))) (SETQ DIR2 (OR (DIRECTORYNAME (OR DIR2 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR2))) (PRINTOUT T "Comparing " DIR1 6 "vs. " DIR2 T "as of " (DATE) " selecting " SELECT " ... ") (SETQ INFOS1 (COMPAREDIRECTORIES.INFOS (CDFILES DIR1 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH1) USEDIRECTORYDATE)) (SETQ INFOS2 (COMPAREDIRECTORIES.INFOS (CDFILES DIR2 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH2) USEDIRECTORYDATE)) (CL:UNLESS (AND INFOS2 INFOS1) (RETURN)) (* ;; "At this point the CAR of each info is the atomic match-name. Peel it off to produce candidate entries.") (* ;;  "Look through all of the I2's because multiple versions (if VERSIONS) have the same matchname") [SETQ CANDIDATES (FOR I1 IN INFOS1 JOIN (IF ALLVERSIONS THEN (OR (FOR I2 IN INFOS2 WHEN (EQ (CAR I2) (CAR I1)) COLLECT (LIST (CAR I1) (CDR I1) (CDR I2))) (CONS (LIST (CAR I1) (CDR I1) NIL))) ELSE (CONS (LIST (CAR I1) (CDR I1) (CDR (ASSOC (CAR I1) INFOS2] (* ;; "Could be some 2's without 1's") (SORT [NCONC CANDIDATES (FOR I2 IN INFOS2 UNLESS (ASSOC (CAR I2) CANDIDATES) COLLECT (LIST (CAR I2) NIL (CDR I2] T) (* ;; "CANDIDATES is now a sorted list of the form (matchname entry1 entry2) where an entry consists of (fullname date length author)") (* ;; "Do the SELECT filtering and insert the date relation.") [SETQ SELECTED (FOR C MATCHNAME INFO1 INFO2 IDATE1 IDATE2 DATEREL BINCOMP IN CANDIDATES EACHTIME (SETQ MATCHNAME (POP C)) (SETQ INFO1 (POP C)) (SETQ INFO2 (POP C)) (IF (AND INFO1 INFO2) THEN (SETQ IDATE1 (IDATE (FETCH DATE OF INFO1))) (SETQ IDATE2 (IDATE (FETCH DATE OF INFO2))) (SETQ DATEREL (IF (IGREATERP IDATE1 IDATE2) THEN '> ELSEIF (ILESSP IDATE1 IDATE2) THEN '< ELSE '=)) ELSE (* ;; "Just for printing--no comparison") (SETQ DATEREL '*)) WHEN (IF (AND INFO1 INFO2) THEN (CL:WHEN (OR (NULL COMPAREDATE) (SELECTQ DATEREL (> (MEMB '> SELECT)) (< (MEMB '< SELECT)) (= (MEMB '= SELECT)) (SHOULDNT))) (SETQ BINCOMP (BINCOMP (FETCH FULLNAME OF INFO1) (FETCH FULLNAME OF INFO2) T (FETCH EOL OF INFO1) (FETCH EOL OF INFO2))) (* ;; "We want the ~= test to reflect exact byte equivalence, including the same EOL. We use the BINCOMP value below to indicate EOL differences, so we check it here.") [NOT (AND (MEMB '~= SELECT) BINCOMP (EQ (FETCH EOL OF INFO1) (FETCH EOL OF INFO2]) ELSEIF INFO1 THEN (* ;; "OK if INFO2 is missing?") (MEMB '*- SELECT) ELSE (* ;; "OK if INFO1 is missing?") (MEMB '-* SELECT)) COLLECT (CREATE CDENTRY MATCHNAME _ MATCHNAME INFO1 _ INFO1 DATEREL _ DATEREL INFO2 _ INFO2 EQUIV _ (CL:UNLESS (EQ DATEREL '*) BINCOMP] (PRINTOUT T (LENGTH SELECTED) " entries" T) (PUSH SELECTED (LIST DIR1 DIR2 SELECT (DATE))) (SETQ LASTCDENTRIES SELECTED) (CL:UNLESS OUTPUTFILE (RETURN SELECTED)) (RETURN (CDPRINT SELECTED OUTPUTFILE (MEMB 'AUTHOR SELECT SELECT]) (CDFILES [LAMBDA (DIR FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH) (* ; "Edited 16-Oct-2020 13:42 by rmk:") (* ;; "Returns a list of fullnames for files that satisfy the criteria") (* ;; "For each name returned by (DIRECTORY DIR), assumes that FILEPATTERNS applies to the suffix after the directory (i.e. after NAMEPOS). That includes possibly subdirectories, dotted files in ultimate file names, and versions.") (* ;; " Exclude subdirectories unless FILEPATTERNS includes *>*") (* ;; " Exclude dotted files (.xxx) unless FILEPATTERNS includes .*") (* ;; " Exclude files with extensions in EXTENSIONSTOAVOID (*=NIL does no filtering)") (* ;; " Exclude older versions unless ALLVERSIONS=T") (* ;; " DEPTH is the number of subdirectories below the ones specified in DIR (NIL top-level of DIR only, T = any depth)") (* ;; "Resolve relative directories, so we can suppress subdirectory matches. ") (SETQ EXTENSIONSTOAVOID (MKLIST (U-CASE EXTENSIONSTOAVOID))) [SETQ FILEPATTERNS (MKLIST (OR FILEPATTERNS '*] (FOR FP FN FPNAME FPEXT EXCLUDEDOTTED (TOPDIR _ (DIRECTORYNAME (OR DIR T))) IN FILEPATTERNS JOIN [SETQ FPNAME (U-CASE (FILENAMEFIELD FP 'NAME] [SETQ FPEXT (U-CASE (FILENAMEFIELD FP 'EXTENSION] (CL:UNLESS FPNAME (IF FPEXT THEN (* ;; ".XY") (SETQ FPNAME (PACK* "." FPEXT)) ELSE (SETQ FPNAME '*))) (CL:UNLESS FPEXT (SETQ FPEXT '*)) (SETQ EXCLUDEDOTTED (NEQ (CHARCODE %.) (CHCON1 FPNAME))) (SETQ FN (PACKFILENAME.STRING 'VERSION (CL:IF ALLVERSIONS '* "") 'DIRECTORY TOPDIR 'NAME '* 'EXTENSION '*)) (* ;; "DEPTH is the number of internal %">%"") [IF (EQ DEPTH T) THEN (SETQ DEPTH MAX.SMALLP) ELSEIF DEPTH ELSE (SETQ DEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FN 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT] (FOR FULLNAME NAME EXT THISDEPTH IN (DIRECTORY FN) EACHTIME [SETQ NAME (U-CASE (FILENAMEFIELD FULLNAME 'NAME] [SETQ EXT (U-CASE (FILENAMEFIELD FULLNAME 'EXTENSION] (CL:UNLESS NAME (IF EXT THEN (* ;; ".XY") (SETQ NAME (PACK* "." EXT)) (SETQ EXT NIL))) (CL:WHEN (AND EXCLUDEDOTTED (EQ (CHARCODE %.) (CHCON1 NAME))) (GO $$ITERATE)) (SETQ THISDEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FULLNAME 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT))) (* ;; "An empty subdirectory may appear without name or extensions") WHEN (AND (OR NAME EXT) (OR (EQ FPNAME '*) (EQ FPNAME NAME)) (OR (EQ FPEXT '*) (EQ FPEXT EXT))) UNLESS [OR (IGREATERP THISDEPTH DEPTH) (AND EXT (OR (MEMB '* EXTENSIONSTOAVOID) (MEMB EXT EXTENSIONSTOAVOID] COLLECT FULLNAME) FINALLY (CL:UNLESS $$VAL (PRINTOUT T "No relevant files in " TOPDIR T]) (COMPAREDIRECTORIES.INFOS [LAMBDA (FILES USEDIRECTORYDATE) (* ; "Edited 13-Oct-2020 08:42 by rmk:") (* ;; "Value is a list of CDINFOS with the match-name consed on to the front") (FOR FULLNAME TYPE LDATE IN FILES COLLECT (* ;; "GDATE/IDATE in case Y2K") (SETQ LDATE (FILEDATE FULLNAME)) (* ; "Is it a Lisp file?") (CONS (MATCHNAME FULLNAME) (CREATE CDINFO FULLNAME _ FULLNAME DATE _ [GDATE (IDATE (IF USEDIRECTORYDATE THEN (GETFILEINFO FULLNAME 'CREATIONDATE) ELSEIF (OR LDATE (GETFILEINFO FULLNAME 'CREATIONDATE] LENGTH _ (GETFILEINFO FULLNAME 'LENGTH) AUTHOR _ (GETFILEINFO FULLNAME 'AUTHOR) TYPE _ (IF LDATE THEN (CL:IF (MEMB (FILENAMEFIELD FULLNAME 'EXTENSION) *COMPILED-EXTENSIONS*) 'COMPILED 'SOURCE) ELSE (PRINTFILETYPE FULLNAME)) EOL _ (EOLTYPE FULLNAME]) (MATCHNAME [LAMBDA (NAME) (* ; "Edited 5-Sep-2020 13:41 by rmk:") (* ;; "The NAME.DIR for matching related files") (LET ((M (PACKFILENAME 'HOST NIL 'VERSION NIL 'DIRECTORY NIL 'BODY NAME))) (* ;; "Strip off the nuisance period") (CL:IF (EQ (CHARCODE %.) (NTHCHARCODE M -1)) (SUBATOM M 1 -2) M)]) ) (DEFINEQ (CDPRINT [LAMBDA (CDENTRIES FILE PRINTAUTHOR) (* ; "Edited 13-Oct-2020 08:38 by rmk:") (* ;; "Typically CDENTRIES will have a header. If not, we fake one up, at least for the directories and today's date.") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (RESETLST (LET (INFO1 TEXT STREAM DATE1POS ENDDATE1 DIR1 DIR2 (HEADER (CAR CDENTRIES)) NCHARSDIR1) (CL:UNLESS (STRINGP (CADR HEADER)) (SETQ HEADER (LIST [FOR E IN CDENTRIES WHEN (FETCH INFO1 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO1 OF E] [FOR E IN CDENTRIES WHEN (FETCH INFO2 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO2 OF E] NIL (DATE))) (PUSH CDENTRIES HEADER)) (SETQ DIR1 (CAR HEADER)) (SETQ NCHARSDIR1 (NCHARS DIR1)) (SETQ DIR2 (CADR HEADER)) (CL:UNLESS (SETQ STREAM (GETSTREAM FILE 'OUTPUT T)) [RESETSAVE (SETQ STREAM (OPENSTREAM (PACKFILENAME 'EXTENSION 'TXT 'BODY FILE) 'OUTPUT 'NEW)) '(PROGN (CLOSEF? OLDVALUE]) (CL:WHEN DIR1 (PRINTOUT STREAM "Comparing " DIR1 6 "vs. " DIR2 T "as of " (CADDDR HEADER)) (CL:WHEN (CADDR HEADER) (PRINTOUT STREAM " selecting " (CADDR HEADER))) (PRINTOUT STREAM -2 (LENGTH (CDR CDENTRIES)) " entries" T T)) (LINELENGTH 1000 STREAM) (* ; "Don't wrap") (* ;; "DATE1POS is the position of the first character of INFO1's date, used for tabbing. We have to measure the filename, date, size, and author if desired") (IF (CDR CDENTRIES) THEN (FOR E INFO1 (MAXDATE1WIDTH _ 0) (SPACEWIDTH _ 1) (PARENWIDTH _ 2) IN (CDR CDENTRIES) WHEN (SETQ INFO1 (FETCH INFO1 OF E)) LARGEST [SETQ MAXDATE1WIDTH (IMAX MAXDATE1WIDTH (NCHARS (FETCH DATE OF INFO1] (IPLUS (- (NCHARS (FETCH FULLNAME OF INFO1)) NCHARSDIR1) (NCHARS (FETCH LENGTH OF INFO1)) (CL:IF PRINTAUTHOR (IPLUS SPACEWIDTH PARENWIDTH (NCHARS (FETCH AUTHOR OF INFO1))) 0)) FINALLY (* ;;  "First 4 for width of equiv. $$EXTREME is NIL if there are no INFO1's") (SETQ DATE1POS (IPLUS (OR $$EXTREME 10) 4 (ITIMES 3 SPACEWIDTH))) (SETQ ENDDATE1 (IPLUS DATE1POS MAXDATE1WIDTH) )) (FOR E IN (CDR CDENTRIES) DO (CDPRINT.LINE STREAM E PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 (NCHARS DIR2))) ELSE (PRINTOUT T "CDENTRIES is empty" T)) (AND STREAM (CLOSEF? STREAM))))]) (CDPRINT.LINE [LAMBDA (STREAM ENTRY PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 NCHARSDIR2) (* ; "Edited 13-Oct-2020 08:51 by rmk:") (* ;; "Format one line of the directory comparison listing. If PRINTAUTHOR and AUTHOR1 or AUTHOR2 are non-NIL, list the author in parens; otherwise omit it.") (LET ((INFO1 (FETCH INFO1 OF ENTRY)) (INFO2 (FETCH INFO2 OF ENTRY))) (PRINTOUT STREAM (SELECTQ (FETCH EQUIV OF ENTRY) (T "==") (NIL " ") (PROGN (SELECTQ (FETCH EOL OF INFO1) (CR 'C) (LF 'L) (CRLF 2) " ") (SELECTQ (FETCH EOL OF INFO2) (CR 'C) (LF 'L) (CRLF 2) " "))) " ") (CL:WHEN INFO1 (PRINTOUT STREAM (SUBSTRING (FETCH FULLNAME OF INFO1) (ADD1 NCHARSDIR1) NIL (CONSTANT (CONCAT))) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO1) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO1) .TAB0 DATE1POS (FETCH DATE OF INFO1))) (PRINTOUT STREAM .TAB0 ENDDATE1 " " (FETCH DATEREL OF ENTRY) " ") (CL:WHEN INFO2 (PRINTOUT STREAM (FETCH DATE OF INFO2) " " (SUBSTRING (FETCH FULLNAME OF INFO2) (ADD1 NCHARSDIR2) NIL (CONSTANT (CONCAT))) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO2) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO2))) (TERPRI STREAM]) ) (DEFINEQ (CDMAP [LAMBDA (CDENTRIES FN) (* ; "Edited 6-Sep-2020 15:58 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) DO (APPLY* FN CDE]) (CDENTRY [LAMBDA (MATCHNAME CDENTRIES) (* ; "Edited 5-Sep-2020 21:09 by rmk:") (ASSOC MATCHNAME (OR CDENTRIES LASTCDENTRIES]) (CDSUBSET [LAMBDA (CDENTRIES FN) (* ; "Edited 15-Sep-2020 13:49 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (CONS (CAR CDENTRIES) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) WHEN (APPLY* FN CDE) COLLECT CDE]) ) (DEFINEQ (BINCOMP [LAMBDA (FILE1 FILE2 EOLDIFFOK EOL1 EOL2) (* ; "Edited 13-Oct-2020 08:53 by rmk:") (* ;; "Returns T if FILE1 and FILE2 are byte-equivalent. Returns EOLDIFF if they are byte equivalent except for CR/LF/CRLF exchanges. ") (* ;; "If EOLDIFFOK, return indicates that the files are the same except for EOL mappings. If EOL1 and EOL2 are not provided, they are computed here.") (IF (IEQP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) THEN [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (* ;; "Simpler code to recompute eol's even if provided") (BIND B1 B2 EOL1 EOL2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS (AND EOLDIFFOK (SELCHARQ B1 (CR (CL:WHEN (EQ EOL1 'LF) (RETURN NIL)) (SETQ EOL1 'CR) (SETQ EOL2 'LF) (EQ B2 (CHARCODE LF))) (LF (CL:WHEN (EQ EOL1 'CR) (RETURN NIL)) (SETQ EOL1 'LF) (SETQ EOL2 'CR) (EQ B2 (CHARCODE CR))) NIL)) (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T] ELSEIF EOLDIFFOK THEN (* ;; "Lengths are different possibly because of CRLF to CR/LF substitutions.") (* ;;  "More complex code could detect the EOLTYPE incrementally without separate passes, but ...") (CL:UNLESS EOL1 (SETQ EOL1 (EOLTYPE FILE1))) (CL:UNLESS EOL2 (SETQ EOL2 (EOLTYPE FILE2))) (CL:WHEN (IF [AND (EQ EOL1 'CRLF) (MEMB EOL2 '(LF CR] ELSEIF [AND (EQ EOL2 'CRLF) (MEMB EOL1 '(LF CR] THEN (SWAP FILE1 FILE2)) (* ;; "FILE1 is now CRLF, FILE2 is not. If FILE1 isn't longer, it can't have a CRLF that corresponds to a CR or LF.") (CL:WHEN (IGREATERP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND B1 B2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS [AND (EQ (CHARCODE CR) B1) (EQ (CHARCODE LF) (\BIN STREAM1)) (MEMB B2 (CHARCODE (CR LF] (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T]))]) (EOLTYPE [LAMBDA (FILE) (* ; "Edited 3-Sep-2020 17:05 by rmk:") (* ;; "Returns the EOLCONVENTION of FILE if it only sees one kind, NIL if it can't decide.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (SETFILEINFO STREAM 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND EOLTYPE DO (SELCHARQ (OR (\BIN STREAM) (RETURN EOLTYPE)) (CR (IF (EQ (CHARCODE LF) (\PEEKBIN STREAM T)) THEN (CL:WHEN (MEMB EOLTYPE '(LF CR)) (RETURN NIL)) (\BIN STREAM) (SETQ EOLTYPE 'CRLF) ELSEIF (MEMB EOLTYPE '(LF CRLF)) THEN (RETURN NIL) ELSE (SETQ EOLTYPE 'CR))) (LF (CL:WHEN (MEMB EOLTYPE '(CR CRLF)) (RETURN NIL)) (SETQ EOLTYPE 'LF)) NIL]) ) (DECLARE%: EVAL@COMPILE (RECORD CDENTRY (MATCHNAME INFO1 DATEREL INFO2 . EQUIV)) (RECORD CDINFO (FULLNAME DATE LENGTH AUTHOR TYPE EOL)) ) (* ;; "look for compiled files older than the sources") (DEFINEQ (FIND-UNCOMPILED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 20-Sep-2020 23:04 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;; "Produces a list of the source files in FILES that have no corresponding compiled file") (* ;; "This determines whether there is at least one compiled file. If there are two or more, that's a problem") (* ;; "We want the most recent version only") (* ;; "Source files have a 2-element created-as with a non-NIL date") (SETQ FILES (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) UNLESS (MEMB (SETQ F (PACKFILENAME 'VERSION NIL 'BODY F)) $$VAL) COLLECT F)) (FOR F SCREATION FILES IN FILES WHEN (AND (CADR (SETQ SCREATION (CREATED-AS F))) (NOT (CDDR SCREATION))) WHEN [SETQ FILES (FOR CEXT CF IN (OR COMPILEEXTS *COMPILED-EXTENSIONS*) WHEN (SETQ CF (INFILEP (PACKFILENAME 'EXTENSION CEXT 'VERSION NIL 'BODY F))) COLLECT (CL:WHEN (SOURCE-FOR-COMPILED-P SCREATION CF DFASLMARGIN) (RETURN NIL)) CF FINALLY (* ;; "If we found some compiled files, they weren't on this source. If there weren't any compiled files to check, maybe there weren't any functions.") (* ;;  "NLSETQ because we don't want to stop if there is an error, typically from a package problem") (RETURN (OR $$VAL (LET [(FCOMS (CAR (NLSETQ (GETDEF (FILECOMS F) 'VARS F] (IF (NULL FCOMS) THEN (* ;;  "GETDEF caused an error. Maybe a package problem. ") (AND NIL 'NOCOMMANDS) ELSEIF (INFILECOMS? NIL '(FUNCTIONS FNS) FCOMS) THEN T] COLLECT (CONS F (SELECTQ FILES (T NIL) (NOCOMMANDS (CONS "No commands")) (FOR CF IN FILES COLLECT (* ;;  "Positive means that compiled is later than source, normal order but maybe by too much.") (* ;;  "Negative means that compiled came before source. Odd") (LIST CF (COMPILE-SOURCE-DATE-DIFF CF SCREATION]) (FIND-UNSOURCED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 15-Sep-2020 15:32 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;;  "Produces a list of compiled FILES for which no source file can be found in the same directory.") (* ;; "The source date in at least one DFASL was off by a second, maybe some sort of IDATE rounding? So, give a margin.") (* ;; "We want the most recent version only. Check CREATED-AS to make sure it really is a compiled file.") (* ;; "Sort to get lcoms and dfasls next to each other.") (LET (CCREATEDS) (SETQ CCREATEDS (FOR CEXT FOUND CCREATED INSIDE (OR COMPILEEXTS *COMPILED-EXTENSIONS*) JOIN (FOR CF IN [OR (LISTP FILES) (FILDIR (PACKFILENAME 'EXTENSION CEXT 'VERSION "" 'BODY '*] WHEN (CDDR (SETQ CCREATED (CREATED-AS CF))) UNLESS (MEMBER CCREATED $$VAL) COLLECT CCREATED))) (* ;; "CCREATEDS is now a list of CREATED-AS items") (FOR CC SF IN CCREATEDS UNLESS (AND [SETQ SF (INFILEP (PACKFILENAME 'EXTENSION NIL 'VERSION NIL 'BODY (CAR CC] (SOURCE-FOR-COMPILED-P (SETQ SF (CREATED-AS SF)) CC DFASLMARGIN)) COLLECT [LIST (CAR CC) (AND SF (LIST (CAR SF) (ROUND (COMPILE-SOURCE-DATE-DIFF CC SF] FINALLY (RETURN (SORT $$VAL (FUNCTION (LAMBDA (CF1 CF2) (ALPHORDER (FILENAMEFIELD (CAR CF1) 'NAME) (FILENAMEFIELD (CAR CF2) 'NAME]) (FIND-SOURCE-FILES [LAMBDA (CFILES SDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (CFILE . SFILES) pairs where CFILE is a Lisp compiled file in CFILES SFILES is a list of source files in SDIRS that CFILE was compiled on.") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ SDIRS (FOR SD INSIDE (OR SDIRS T) COLLECT (DIRECTORYNAME SD))) (SORT (FOR CF SFILES CNAME CCREATED IN (OR (LISTP CFILES) (FILDIR CFILES)) WHEN (AND (SETQ CNAME (INFILEP CF)) (CDDR (SETQ CCREATED (CREATED-AS CF))) (SETQ SFILES (FOR SD SF IN SDIRS WHEN (AND (SETQ SF (INFILEP (PACKFILENAME 'NAME (FILENAMEFIELD CF 'NAME) 'BODY SD))) (SOURCE-FOR-COMPILED-P SF CCREATED DFASLMARGIN)) COLLECT SF))) COLLECT (CONS CNAME SFILES)) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-COMPILED-FILES [LAMBDA (SFILES CDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (SFILE . CFILES) pairs where SFILE is a Lisp source file in SFILES CFILES is a list of compiled files in CDIRS that were compiled on SFILE.") (* ;; "FILEDATE is true for source files and compiled files") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ CDIRS (FOR CD INSIDE (OR CDIRS T) COLLECT (DIRECTORYNAME CD))) (SORT (FOR SF CFILES SNAME SCREATED IN (OR (LISTP SFILES) (FILDIR SFILES)) WHEN [AND (SETQ SNAME (INFILEP SF)) (SETQ SCREATED (CREATED-AS SF)) (NOT (CDDR SCREATED)) (SETQ CFILES (FOR CEXT (ROOT _ (FILENAMEFIELD SNAME 'NAME)) IN *COMPILED-EXTENSIONS* JOIN (FOR CD CF IN CDIRS WHEN (AND (SETQ CF (INFILEP (PACKFILENAME 'NAME ROOT 'EXTENSION CEXT 'BODY CD))) (SOURCE-FOR-COMPILED-P SCREATED CF DFASLMARGIN)) COLLECT CF] COLLECT (CONS SNAME CFILES )) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-UNLOADED-FILES [LAMBDA (FILES) (* ; "Edited 9-Sep-2020 19:35 by rmk:") (* ;; "Returns the files in FILES that don't have FILECREATED properties and presumably are therefore not loaded in the current sysout.") (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (AND (SETQ F (INFILEP (CL:IF (LISTP F) (CAR F) F))) (FILEDATE F)) UNLESS (GETP (FILENAMEFIELD F 'NAME) 'FILEDATES) COLLECT F]) (FIND-LOADED-FILES [LAMBDA (ROOTFILENAMES) (* ; "Edited 19-Sep-2020 07:20 by rmk:") (FOR RN INSIDE ROOTFILENAMES WHEN (GETP RN 'FILEDATES) COLLECT (CONS RN (FOR F IN LOADEDFILELST WHEN (EQ RN (FILENAMEFIELD F 'NAME)) COLLECT F]) (FIND-MULTICOMPILED-FILES [LAMBDA (FILES SHOWINFO) (* ; "Edited 20-Sep-2020 20:57 by rmk:") (* ;; "Returns a list of names for files in FILES that have multiple compilations") (LET (SFILES) (FOR F EXT NAME IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (MEMB (SETQ EXT (FILENAMEFIELD F 'EXTENSION)) *COMPILED-EXTENSIONS*) DO (SETQ NAME (FILENAMEFIELD F 'NAME)) (* ;; "PUSHNEW because we haven't filtered out versions") (PUSHNEW [CDR (OR (ASSOC NAME SFILES) (CAR (PUSH SFILES (CONS NAME] EXT)) (FOR S IN SFILES WHEN (CDDR S) COLLECT (IF SHOWINFO THEN `[,(CAR S) ,(CADAR (FIND-LOADED-FILES (CAR S))) ,(CREATED-AS (CAR S)) ,@(FOR EXT IN (SORT (CDR S)) COLLECT (CREATED-AS (PACKFILENAME 'EXTENSION EXT 'BODY (CAR S] ELSE (CAR S]) ) (DEFINEQ (CREATED-AS [LAMBDA (FILE) (* ; "Edited 20-Sep-2020 23:06 by rmk:") (* ;; "For lisp source files, returns (filecreatename filecreateddate)") (* ;; "For lisp compiled files, returns (cfilename cfiledate sfilecreatename sfilecreateddate)") (* ;; "For other files, (fullfilename NIL)") (* ;; "The cfilename is just the current directory name for DFASLs.") (* ;; "So: (CADR value) is non-NIL for Lisp files. Of those, (CDDR value) is non-NIL for compiled files.") (* ;; "We disable the package delimiter because the atoms in changes may have a packages that we don't know.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (LET (FILEDATE FILENAME SOURCEDATE SOURCENAME LINE POS) [IF (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) THEN (* ; "Managed source or LCOM") (RESETLST [LET (FORM SFORM (RDTBL (FIND-READTABLE "OLD-INTERLISP-FILE"))) (SETQ POS (GETFILEPTR STREAM)) (READCCODE STREAM) (IF (EQ 'DEFINE-FILE-INFO (RATOM STREAM RDTBL)) THEN (* ;; "Reading is package-safe") (SETFILEPTR STREAM POS) (SETQ FORM (READ STREAM RDTBL)) (SETQ RDTBL (FIND-READTABLE (LISTGET (CDR FORM) :READTABLE))) ELSE (SETFILEPTR STREAM POS)) (CL:WHEN (EQ 'PACKAGEDELIM (GETSYNTAX '%: RDTBL)) [RESETSAVE (SETSYNTAX '%: 'OTHER RDTBL) `(SETSYNTAX %: PACKAGEDELIM ,RDTBL]) (* ;; "One way or the other, we're ready for the filecreated") (CL:WHEN (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (SETQ FORM (READ STREAM RDTBL)) (CL:WHEN (MEMB (U-CASE (CAR FORM)) '(FILECREATED IL%:FILECREATED)) (* ;; "IL%%:FILECREATED because we screwed the readtable.") (IF [STREQUAL "compiled on " (CAR (LISTP (CADDR FORM] THEN (* ; "LCOM, get source info") (IF [AND (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (MEMB [U-CASE (CAR (SETQ SFORM (READ STREAM RDTBL] '(FILECREATED IL%:FILECREATED] THEN (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM)) (SETQ SOURCENAME (CADDR SFORM)) (SETQ SOURCEDATE (CADR SFORM)) ELSE (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM))) ELSE (SETQ FILENAME (CADDR FORM)) (SETQ FILEDATE (CADR FORM)))))]) ELSEIF (SETQ POS (STRPOS "XCL Compiler output for source file " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) THEN (* ; "DFASL compiled?") (SETQ SOURCENAME (SUBATOM LINE POS)) (CL:WHEN (SETQ POS (STRPOS "Source file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ SOURCEDATE (GDATE (IDATE (SUBSTRING LINE POS] (CL:WHEN (SETQ POS (STRPOS "FASL file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ FILEDATE (GDATE (IDATE (SUBSTRING LINE POS]))] (* ;; "Revert filenames to Interlisp package if needed:") (CL:WHEN (STRPOS "IL:" FILENAME) (SETQ FILENAME (SUBATOM FILENAME 4))) (CL:WHEN (STRPOS "IL:" SOURCENAME) (SETQ SOURCENAME (MKATOM SOURCENAME 4))) (* ;; "Return DATE NIL if file is not a Lisp file") `(,(OR FILENAME (FULLNAME STREAM)) ,(AND FILEDATE (GDATE (IDATE FILEDATE))) ,@(CL:WHEN SOURCENAME (LIST SOURCENAME (GDATE (IDATE SOURCEDATE))))]) (SOURCE-FOR-COMPILED-P [LAMBDA (SOURCE COMPILED DFASLMARGIN) (* ; "Edited 31-Oct-2020 09:12 by rmk:") (* ;; "There seems to be some variation between the source dates in dfasl files and the filecreated date in the sources, they often don't match exactly. But if they are within DFASLMARGIN, we assume a match. We require exact date match for LCOMS") (* ;; "This is needed for dfasl files created before they recorded the source filecreated name and date instead of the directory source name and date when compile took place.") (* ;; "") (* ;; "DFASLMARGIN is a pair (after before) where we assume a match if the compiled date is no more than after minutes after the source date and no more than before minuts before (the diff is negative then).") (* ;; "A single positive integer x is interpreted as (x 0). A single negative integer x is interpreted as (-x x) (before or after x).") (* ;; "Default is (20 0).") (* ;; "T is positive or negative infinity") (CL:UNLESS (LISTP SOURCE) (SETQ SOURCE (CREATED-AS SOURCE))) (CL:UNLESS (LISTP COMPILED) (SETQ COMPILED (CREATED-AS COMPILED))) (SETQ DFASLMARGIN (IF (NULL DFASLMARGIN) THEN (* ;;  "If compiled is later than source by less than 20 minutes, it's probably OK") '(20 0) ELSEIF (EQ T DFASLMARGIN) THEN '(T 0) ELSEIF (LISTP DFASLMARGIN) ELSEIF (NOT (FIXP DFASLMARGIN)) THEN (ERROR "ILLEGAL DFASLMARGIN" DFASLMARGIN) ELSEIF (MINUSP DFASLMARGIN) THEN (LIST (MINUS DFASLMARGIN) DFASLMARGIN) ELSE (LIST DFASLMARGIN 0))) (OR (EQUAL (CAR SOURCE) (CADDR COMPILED)) (EQUAL (CADR SOURCE) (CADDDR COMPILED)) (AND [EQ 'DFASL (U-CASE (FILENAMEFIELD (CAR COMPILED) 'EXTENSION] (LET ((TIMEDIFF (COMPILE-SOURCE-DATE-DIFF COMPILED SOURCE))) (* ;; "If compiled was no more than 20 minutes later, it's probably OK. Of no more than DFASLMARGIN earlier, if it is negative.") (AND (OR (EQ T (CAR DFASLMARGIN)) (LEQ TIMEDIFF (CAR DFASLMARGIN))) (OR (EQ T (CADR DFASLMARGIN)) (GEQ TIMEDIFF (CADR DFASLMARGIN]) (COMPILE-SOURCE-DATE-DIFF [LAMBDA (CFILE SFILE) (* ; "Edited 20-Sep-2020 22:59 by rmk:") (* ;; "Positive means that compiled is later than source, normal order but maybe by too much. Negative means that compiled came before source, i.e., compiled on a source that didn't yet exist.") (* ;; "Value is in minutes") (ROUND (FQUOTIENT [IDIFFERENCE [IDATE (CADDDR (OR (LISTP CFILE) (CREATED-AS CFILE] (IDATE (CADR (OR (LISTP SFILE) (CREATED-AS SFILE] (TIMES 60 ONESECOND]) ) (DEFINEQ (FIX-DIRECTORY-DATES [LAMBDA (FILES MARGIN) (* ; "Edited 30-Oct-2020 22:01 by rmk:") (* ;; "For Lisp source and compiled files, ensures that the directory file date corresponds to the filecreated date. Returns the list of files whose dates were changed.") (* ;; "This allows for the fact that directory dates that are no later than, say, 30 seconds of the filecreated date are probably OK--the directory date may be set when the file is closed.") (* ;; "Use IDATEs in case FDCDATE is not Y2K.") (* ;; "Stop if directory date is more than 2 minutes earlier than the filecreated date. Earlier could be because the dates are asserted at different points in the filing process. But 2 minutes is worth thinking about. Returning from HELP will get them aligned.") (SETQ MARGIN (ITIMES (OR MARGIN 2) 60 ONESECOND)) (FOR F DIDATE FCDATE IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (SETQ FCDATE (FILEDATE F)) UNLESS (IEQP (SETQ DIDATE (GETFILEINFO F 'ICREATIONDATE)) (SETQ FCDATE (IDATE FCDATE))) COLLECT (CL:WHEN (IGREATERP (IDIFFERENCE FCDATE DIDATE) MARGIN) (HELP "DIRECTORY DATE EARLIER THAN FILECREATED DATE" (LIST F (GDATE DIDATE) (GDATE FCDATE)))) (SETFILEINFO F 'ICREATIONDATE FCDATE) F]) (FIX-EQUIV-DATES [LAMBDA (CDENTRIES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "For every entry whose files are EQUIVALENT and whose filedates are different, sets the directory of the file with the later date to be the date of the one with the earlier date. This preumes that the later one must have been a copy. ") (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE EARLY LATE IN (CDR CDENTRIES) WHEN (FETCH EQUIV OF CDE) UNLESS (EQ '= (FETCH DATEREL OF CDE)) COLLECT (SELECTQ (FETCH DATEREL OF CDE) (> (SETQ EARLY (FETCH INFO2 OF CDE)) (SETQ LATE (FETCH INFO1 OF CDE))) (< (SETQ EARLY (FETCH INFO1 OF CDE)) (SETQ LATE (FETCH INFO2 OF CDE))) (SHOULDNT)) (SETFILEINFO (FETCH FULLNAME OF LATE) 'ICREATIONDATE (GETFILEINFO (FETCH FULLNAME OF EARLY) 'ICREATIONDATE)) (FETCH FULLNAME OF LATE]) (COPY-COMPARED-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:20 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO MATCHNAME IN (CDR CDENTRIES) EACHTIME (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) WHEN (AND (FETCH FULLNAME OF SINFO) (FETCH FULLNAME OF TINFO)) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'VERSION NIL 'BODY (FETCH FULLNAME OF TINFO))) MATCHNAME]) (COPY-MISSING-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (CL:UNLESS (STRINGP (CADR (CAR CDENTRIES))) (ERROR "(CAR CDENTRIES) IS NOT A VALID PARAMETER LIST" (CAR CDENTRIES))) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO TDIR MATCHNAME (TDIR _ (CL:IF (EQ TARGET 1) (CAAR CDENTRIES) (CADAR CDENTRIES))) IN (CDR CDENTRIES) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) WHEN (AND (FETCH FULLNAME OF SINFO) (NOT (FETCH FULLNAME OF TINFO))) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (* ;; "Using the source fullname in the target should preserve the version number") (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'BODY TDIR 'BODY (FETCH FULLNAME OF SINFO))) MATCHNAME]) (COMPILED-ON-SAME-SOURCE [LAMBDA (CDENTRIES) (* ; "Edited 9-Sep-2020 13:00 by rmk:") (* ;; "Returms a subset of CDENTRIES consisting of files that are compiled on the same source (i.e. their source names or dates are the same). Preserves the header.") (CDSUBSET CDENTRIES (FUNCTION (LAMBDA (CDE) (DECLARE (USEDFREE INFO1 INFO2)) (LET (CREATED1 CREATED2) (CL:WHEN [AND (EQ 'COMPILED (FETCH TYPE OF INFO1)) (EQ 'COMPILED (FETCH TYPE OF INFO2)) [CDDR (SETQ CREATED1 (CREATED-AS (FETCH FULLNAME OF INFO1] (CDDR (SETQ CREATED2 (CREATED-AS (FETCH FULLNAME OF INFO2] (OR (EQUAL (CADDR CREATED1) (CADDR CREATED2)) (EQUAL (CADDDR CREATED1) (CADDDR CREATED2))))]) ) (RPAQ ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"))) (RPAQ? LASTCDENTRIES NIL) (DEFINEQ (COMPARE-ENTRY-SOURCE-FILES [LAMBDA (CDENTRY LISTSTREAM EXAMINE DW?) (* ; "Edited 30-Aug-2020 12:22 by rmk:") (* ;; "Wrapper to call COMPARESOURCES on the Lisp source files of CDENTRY") (CL:WHEN [AND (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO1 OF CDENTRY))) (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO2 OF CDENTRY] (COMPARESOURCES (FETCH FULLNAME OF (FETCH INFO1 OF CDENTRY)) (FETCH FULLNAME OF (FETCH INFO2 OF CDENTRY)) EXAMINE DW? LISTSTREAM))]) ) (FILESLOAD COMPARESOURCES) (PUTPROPS COMPAREDIRECTORIES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1994 1998 2018 2020 2021)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1632 17400 (COMPAREDIRECTORIES 1642 . 10869) (CDFILES 10871 . 15446) ( COMPAREDIRECTORIES.INFOS 15448 . 16963) (MATCHNAME 16965 . 17398)) (17401 24586 (CDPRINT 17411 . 22211 ) (CDPRINT.LINE 22213 . 24584)) (24587 26339 (CDMAP 24597 . 25293) (CDENTRY 25295 . 25463) (CDSUBSET 25465 . 26337)) (26340 31871 (BINCOMP 26350 . 30639) (EOLTYPE 30641 . 31869)) (32084 45291 ( FIND-UNCOMPILED-FILES 32094 . 35737) (FIND-UNSOURCED-FILES 35739 . 38548) (FIND-SOURCE-FILES 38550 . 40254) (FIND-COMPILED-FILES 40256 . 42334) (FIND-UNLOADED-FILES 42336 . 43080) (FIND-LOADED-FILES 43082 . 43636) (FIND-MULTICOMPILED-FILES 43638 . 45289)) (45292 53494 (CREATED-AS 45302 . 50099) ( SOURCE-FOR-COMPILED-P 50101 . 52799) (COMPILE-SOURCE-DATE-DIFF 52801 . 53492)) (53495 62474 ( FIX-DIRECTORY-DATES 53505 . 55473) (FIX-EQUIV-DATES 55475 . 56735) (COPY-COMPARED-FILES 56737 . 58861) (COPY-MISSING-FILES 58863 . 60702) (COMPILED-ON-SAME-SOURCE 60704 . 62472)) (62629 63240 ( COMPARE-ENTRY-SOURCE-FILES 62639 . 63238))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "21-Feb-2021 20:37:49"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>COMPAREDIRECTORIES.;282 65535 changes to%: (FNS EOLTYPE EOLTYPE.SHOW) (VARS COMPAREDIRECTORIESCOMS) previous date%: "21-Feb-2021 00:14:38" {DSK}kaplan>Local>medley3.5>git-medley>lispusers>COMPAREDIRECTORIES.;278) (* ; " Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corporation. ") (PRETTYCOMPRINT COMPAREDIRECTORIESCOMS) (RPAQQ COMPAREDIRECTORIESCOMS ( (* ;; "Compare the contents of two directories.") (FNS COMPAREDIRECTORIES CDFILES COMPAREDIRECTORIES.INFOS MATCHNAME MEDLEY-FIX-DIRS) (VARS MEDLEY-FIX-DIRS) (FNS CDPRINT CDPRINT.LINE) (FNS CDMAP CDENTRY CDSUBSET) (FNS BINCOMP EOLTYPE EOLTYPE.SHOW) (RECORDS CDENTRY CDINFO) (* ;; "look for compiled files older than the sources") (FNS FIND-UNCOMPILED-FILES FIND-UNSOURCED-FILES FIND-SOURCE-FILES FIND-COMPILED-FILES FIND-UNLOADED-FILES FIND-LOADED-FILES FIND-MULTICOMPILED-FILES) (FNS CREATED-AS SOURCE-FOR-COMPILED-P COMPILE-SOURCE-DATE-DIFF) (FNS FIX-DIRECTORY-DATES FIX-EQUIV-DATES COPY-COMPARED-FILES COPY-MISSING-FILES COMPILED-ON-SAME-SOURCE) [VARS (ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"] (INITVARS (LASTCDENTRIES NIL)) (COMS (FNS COMPARE-ENTRY-SOURCE-FILES) (FILES COMPARESOURCES)))) (* ;; "Compare the contents of two directories.") (DEFINEQ (COMPAREDIRECTORIES [LAMBDA (DIR1 DIR2 SELECT FILEPATTERNS EXTENSIONSTOAVOID USEDIRECTORYDATE OUTPUTFILE ALLVERSIONS) (* ; "Edited 7-Jan-2021 23:21 by rmk:") (* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on DIR1 and DIR2, listing which is newer, or when one is not found on the other. If SELECT is or contains SAME/=, BEFORE/<, AFTER/>, then files where DIR1 is the same as, earlier than, or later than DIR2 are selected. SELECT= NIL is the same as (< >), T is the same as (< > =). Also allows selection based on file-length criteria.") (* ;; "") (* ;; "Unless USEDIRECTORYDATE, comparison is with respect to the the LISP filecreated dates if evailable.") (* ;; "") (* ;; "If OUTPUTFILE is NIL, the list of compared entries is returned. Otherwise the selected entries are printed on OUTPUTFILE (T for the display).") [SETQ SELECT (SELECTQ SELECT (NIL '(< > -* *-)) (T '(< > -* *- =)) (FOR S IN (MKLIST SELECT) COLLECT (SELECTQ S ((AFTER >) '>) ((BEFORE <) '<) ((SAME SAMEDATE =) '=) (AUTHOR 'AUTHOR) (-* '-*) (*- '*-) (~= '~=) (ERROR "UNRECOGNIZED SELECT PARAMETER" S] (PROG (INFOS1 INFOS2 CANDIDATES SELECTED COMPAREDATE DEPTH1 DEPTH2) [SETQ COMPAREDATE (INTERSECTION SELECT '(< > =] (* ;; "DIRECTORYNAME here to get unrelativized specifications for header.") (* ;; "Allow all subdirectories if a directory ends in *, but peel it off for the resolution") (CL:WHEN (EQ '* (NTHCHAR DIR1 -1)) (SETQ DEPTH1 T) (SETQ DIR1 (SUBSTRING DIR1 1 -2))) (CL:WHEN (EQ '* (NTHCHAR DIR2 -1)) (SETQ DEPTH2 T) (SETQ DIR2 (SUBSTRING DIR2 1 -2))) (SETQ DIR1 (OR (DIRECTORYNAME (OR DIR1 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR1))) (SETQ DIR2 (OR (DIRECTORYNAME (OR DIR2 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR2))) (PRINTOUT T "Comparing " DIR1 6 "vs. " DIR2 T "as of " (DATE) " selecting " SELECT " ... ") (SETQ INFOS1 (COMPAREDIRECTORIES.INFOS (CDFILES DIR1 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH1) USEDIRECTORYDATE)) (SETQ INFOS2 (COMPAREDIRECTORIES.INFOS (CDFILES DIR2 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH2) USEDIRECTORYDATE)) (CL:UNLESS (AND INFOS2 INFOS1) (RETURN)) (* ;; "At this point the CAR of each info is the atomic match-name. Peel it off to produce candidate entries.") (* ;;  "Look through all of the I2's because multiple versions (if VERSIONS) have the same matchname") [SETQ CANDIDATES (FOR I1 IN INFOS1 JOIN (IF ALLVERSIONS THEN (OR (FOR I2 IN INFOS2 WHEN (EQ (CAR I2) (CAR I1)) COLLECT (LIST (CAR I1) (CDR I1) (CDR I2))) (CONS (LIST (CAR I1) (CDR I1) NIL))) ELSE (CONS (LIST (CAR I1) (CDR I1) (CDR (ASSOC (CAR I1) INFOS2] (* ;; "Could be some 2's without 1's") (SORT [NCONC CANDIDATES (FOR I2 IN INFOS2 UNLESS (ASSOC (CAR I2) CANDIDATES) COLLECT (LIST (CAR I2) NIL (CDR I2] T) (* ;; "CANDIDATES is now a sorted list of the form (matchname entry1 entry2) where an entry consists of (fullname date length author)") (* ;; "Do the SELECT filtering and insert the date relation.") [SETQ SELECTED (FOR C MATCHNAME INFO1 INFO2 IDATE1 IDATE2 DATEREL BINCOMP IN CANDIDATES EACHTIME (SETQ MATCHNAME (POP C)) (SETQ INFO1 (POP C)) (SETQ INFO2 (POP C)) (IF (AND INFO1 INFO2) THEN (SETQ IDATE1 (IDATE (FETCH DATE OF INFO1))) (SETQ IDATE2 (IDATE (FETCH DATE OF INFO2))) (SETQ DATEREL (IF (IGREATERP IDATE1 IDATE2) THEN '> ELSEIF (ILESSP IDATE1 IDATE2) THEN '< ELSE '=)) ELSE (* ;; "Just for printing--no comparison") (SETQ DATEREL '*)) WHEN (IF (AND INFO1 INFO2) THEN (CL:WHEN (OR (NULL COMPAREDATE) (SELECTQ DATEREL (> (MEMB '> SELECT)) (< (MEMB '< SELECT)) (= (MEMB '= SELECT)) (SHOULDNT))) (SETQ BINCOMP (BINCOMP (FETCH FULLNAME OF INFO1) (FETCH FULLNAME OF INFO2) T (FETCH EOL OF INFO1) (FETCH EOL OF INFO2))) (* ;; "We want the ~= test to reflect exact byte equivalence, including the same EOL. We use the BINCOMP value below to indicate EOL differences, so we check it here.") [NOT (AND (MEMB '~= SELECT) BINCOMP (EQ (FETCH EOL OF INFO1) (FETCH EOL OF INFO2]) ELSEIF INFO1 THEN (* ;; "OK if INFO2 is missing?") (MEMB '*- SELECT) ELSE (* ;; "OK if INFO1 is missing?") (MEMB '-* SELECT)) COLLECT (CREATE CDENTRY MATCHNAME _ MATCHNAME INFO1 _ INFO1 DATEREL _ DATEREL INFO2 _ INFO2 EQUIV _ (CL:UNLESS (EQ DATEREL '*) BINCOMP] (PRINTOUT T (LENGTH SELECTED) " entries" T) (PUSH SELECTED (LIST DIR1 DIR2 SELECT (DATE))) (SETQ LASTCDENTRIES SELECTED) (CL:UNLESS OUTPUTFILE (RETURN SELECTED)) (RETURN (CDPRINT SELECTED OUTPUTFILE (MEMB 'AUTHOR SELECT SELECT]) (CDFILES [LAMBDA (DIR FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH) (* ; "Edited 16-Oct-2020 13:42 by rmk:") (* ;; "Returns a list of fullnames for files that satisfy the criteria") (* ;; "For each name returned by (DIRECTORY DIR), assumes that FILEPATTERNS applies to the suffix after the directory (i.e. after NAMEPOS). That includes possibly subdirectories, dotted files in ultimate file names, and versions.") (* ;; " Exclude subdirectories unless FILEPATTERNS includes *>*") (* ;; " Exclude dotted files (.xxx) unless FILEPATTERNS includes .*") (* ;; " Exclude files with extensions in EXTENSIONSTOAVOID (*=NIL does no filtering)") (* ;; " Exclude older versions unless ALLVERSIONS=T") (* ;; " DEPTH is the number of subdirectories below the ones specified in DIR (NIL top-level of DIR only, T = any depth)") (* ;; "Resolve relative directories, so we can suppress subdirectory matches. ") (SETQ EXTENSIONSTOAVOID (MKLIST (U-CASE EXTENSIONSTOAVOID))) [SETQ FILEPATTERNS (MKLIST (OR FILEPATTERNS '*] (FOR FP FN FPNAME FPEXT EXCLUDEDOTTED (TOPDIR _ (DIRECTORYNAME (OR DIR T))) IN FILEPATTERNS JOIN [SETQ FPNAME (U-CASE (FILENAMEFIELD FP 'NAME] [SETQ FPEXT (U-CASE (FILENAMEFIELD FP 'EXTENSION] (CL:UNLESS FPNAME (IF FPEXT THEN (* ;; ".XY") (SETQ FPNAME (PACK* "." FPEXT)) ELSE (SETQ FPNAME '*))) (CL:UNLESS FPEXT (SETQ FPEXT '*)) (SETQ EXCLUDEDOTTED (NEQ (CHARCODE %.) (CHCON1 FPNAME))) (SETQ FN (PACKFILENAME.STRING 'VERSION (CL:IF ALLVERSIONS '* "") 'DIRECTORY TOPDIR 'NAME '* 'EXTENSION '*)) (* ;; "DEPTH is the number of internal %">%"") [IF (EQ DEPTH T) THEN (SETQ DEPTH MAX.SMALLP) ELSEIF DEPTH ELSE (SETQ DEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FN 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT] (FOR FULLNAME NAME EXT THISDEPTH IN (DIRECTORY FN) EACHTIME [SETQ NAME (U-CASE (FILENAMEFIELD FULLNAME 'NAME] [SETQ EXT (U-CASE (FILENAMEFIELD FULLNAME 'EXTENSION] (CL:UNLESS NAME (IF EXT THEN (* ;; ".XY") (SETQ NAME (PACK* "." EXT)) (SETQ EXT NIL))) (CL:WHEN (AND EXCLUDEDOTTED (EQ (CHARCODE %.) (CHCON1 NAME))) (GO $$ITERATE)) (SETQ THISDEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FULLNAME 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT))) (* ;; "An empty subdirectory may appear without name or extensions") WHEN (AND (OR NAME EXT) (OR (EQ FPNAME '*) (EQ FPNAME NAME)) (OR (EQ FPEXT '*) (EQ FPEXT EXT))) UNLESS [OR (IGREATERP THISDEPTH DEPTH) (AND EXT (OR (MEMB '* EXTENSIONSTOAVOID) (MEMB EXT EXTENSIONSTOAVOID] COLLECT FULLNAME) FINALLY (CL:UNLESS $$VAL (PRINTOUT T "No relevant files in " TOPDIR T]) (COMPAREDIRECTORIES.INFOS [LAMBDA (FILES USEDIRECTORYDATE) (* ; "Edited 13-Oct-2020 08:42 by rmk:") (* ;; "Value is a list of CDINFOS with the match-name consed on to the front") (FOR FULLNAME TYPE LDATE IN FILES COLLECT (* ;; "GDATE/IDATE in case Y2K") (SETQ LDATE (FILEDATE FULLNAME)) (* ; "Is it a Lisp file?") (CONS (MATCHNAME FULLNAME) (CREATE CDINFO FULLNAME _ FULLNAME DATE _ [GDATE (IDATE (IF USEDIRECTORYDATE THEN (GETFILEINFO FULLNAME 'CREATIONDATE) ELSEIF (OR LDATE (GETFILEINFO FULLNAME 'CREATIONDATE] LENGTH _ (GETFILEINFO FULLNAME 'LENGTH) AUTHOR _ (GETFILEINFO FULLNAME 'AUTHOR) TYPE _ (IF LDATE THEN (CL:IF (MEMB (FILENAMEFIELD FULLNAME 'EXTENSION) *COMPILED-EXTENSIONS*) 'COMPILED 'SOURCE) ELSE (PRINTFILETYPE FULLNAME)) EOL _ (EOLTYPE FULLNAME]) (MATCHNAME [LAMBDA (NAME) (* ; "Edited 5-Sep-2020 13:41 by rmk:") (* ;; "The NAME.DIR for matching related files") (LET ((M (PACKFILENAME 'HOST NIL 'VERSION NIL 'DIRECTORY NIL 'BODY NAME))) (* ;; "Strip off the nuisance period") (CL:IF (EQ (CHARCODE %.) (NTHCHARCODE M -1)) (SUBATOM M 1 -2) M)]) (MEDLEY-FIX-DIRS [LAMBDA (DIRS) (* ; "Edited 8-Jan-2021 23:00 by rmk:") (* ;  "Edited 4-Jan-2021 15:42 by larry") (for X in (OR (MKLIST DIRS) MEDLEY-FIX-DIRS) join (FIX-DIRECTORY-DATES (MEDLEYDIR (PRINT X T]) ) (RPAQQ MEDLEY-FIX-DIRS ("sources" "library" "lispusers" "internal/library" "greetfiles" "docs>Documentation Tools" "cltl2" "clos")) (DEFINEQ (CDPRINT [LAMBDA (CDENTRIES FILE PRINTAUTHOR) (* ; "Edited 13-Oct-2020 08:38 by rmk:") (* ;; "Typically CDENTRIES will have a header. If not, we fake one up, at least for the directories and today's date.") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (RESETLST (LET (INFO1 TEXT STREAM DATE1POS ENDDATE1 DIR1 DIR2 (HEADER (CAR CDENTRIES)) NCHARSDIR1) (CL:UNLESS (STRINGP (CADR HEADER)) (SETQ HEADER (LIST [FOR E IN CDENTRIES WHEN (FETCH INFO1 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO1 OF E] [FOR E IN CDENTRIES WHEN (FETCH INFO2 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO2 OF E] NIL (DATE))) (PUSH CDENTRIES HEADER)) (SETQ DIR1 (CAR HEADER)) (SETQ NCHARSDIR1 (NCHARS DIR1)) (SETQ DIR2 (CADR HEADER)) (CL:UNLESS (SETQ STREAM (GETSTREAM FILE 'OUTPUT T)) [RESETSAVE (SETQ STREAM (OPENSTREAM (PACKFILENAME 'EXTENSION 'TXT 'BODY FILE) 'OUTPUT 'NEW)) '(PROGN (CLOSEF? OLDVALUE]) (CL:WHEN DIR1 (PRINTOUT STREAM "Comparing " DIR1 6 "vs. " DIR2 T "as of " (CADDDR HEADER)) (CL:WHEN (CADDR HEADER) (PRINTOUT STREAM " selecting " (CADDR HEADER))) (PRINTOUT STREAM -2 (LENGTH (CDR CDENTRIES)) " entries" T T)) (LINELENGTH 1000 STREAM) (* ; "Don't wrap") (* ;; "DATE1POS is the position of the first character of INFO1's date, used for tabbing. We have to measure the filename, date, size, and author if desired") (IF (CDR CDENTRIES) THEN (FOR E INFO1 (MAXDATE1WIDTH _ 0) (SPACEWIDTH _ 1) (PARENWIDTH _ 2) IN (CDR CDENTRIES) WHEN (SETQ INFO1 (FETCH INFO1 OF E)) LARGEST [SETQ MAXDATE1WIDTH (IMAX MAXDATE1WIDTH (NCHARS (FETCH DATE OF INFO1] (IPLUS (- (NCHARS (FETCH FULLNAME OF INFO1)) NCHARSDIR1) (NCHARS (FETCH LENGTH OF INFO1)) (CL:IF PRINTAUTHOR (IPLUS SPACEWIDTH PARENWIDTH (NCHARS (FETCH AUTHOR OF INFO1))) 0)) FINALLY (* ;;  "First 4 for width of equiv. $$EXTREME is NIL if there are no INFO1's") (SETQ DATE1POS (IPLUS (OR $$EXTREME 10) 4 (ITIMES 3 SPACEWIDTH))) (SETQ ENDDATE1 (IPLUS DATE1POS MAXDATE1WIDTH) )) (FOR E IN (CDR CDENTRIES) DO (CDPRINT.LINE STREAM E PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 (NCHARS DIR2))) ELSE (PRINTOUT T "CDENTRIES is empty" T)) (AND STREAM (CLOSEF? STREAM))))]) (CDPRINT.LINE [LAMBDA (STREAM ENTRY PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 NCHARSDIR2) (* ; "Edited 9-Jan-2021 10:12 by rmk:") (* ;; "Format one line of the directory comparison listing. If PRINTAUTHOR and AUTHOR1 or AUTHOR2 are non-NIL, list the author in parens; otherwise omit it.") (LET ((INFO1 (FETCH INFO1 OF ENTRY)) (INFO2 (FETCH INFO2 OF ENTRY))) (PRINTOUT STREAM (SELECTQ (FETCH EQUIV OF ENTRY) (T "==") (NIL " ") (CONCAT (SELECTQ (CAR (FETCH EQUIV OF ENTRY)) (CR 'C) (LF 'L) (CRLF 2) "x") (SELECTQ (CADR (FETCH EQUIV OF ENTRY)) (CR 'C) (LF 'L) (CRLF 2) "x"))) " ") (CL:WHEN INFO1 (PRINTOUT STREAM (SUBSTRING (FETCH FULLNAME OF INFO1) (ADD1 NCHARSDIR1) NIL (CONSTANT (CONCAT))) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO1) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO1) .TAB0 DATE1POS (FETCH DATE OF INFO1))) (PRINTOUT STREAM .TAB0 ENDDATE1 " " (FETCH DATEREL OF ENTRY) " ") (CL:WHEN INFO2 (PRINTOUT STREAM (FETCH DATE OF INFO2) " " (SUBSTRING (FETCH FULLNAME OF INFO2) (ADD1 NCHARSDIR2) NIL (CONSTANT (CONCAT))) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO2) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO2))) (TERPRI STREAM]) ) (DEFINEQ (CDMAP [LAMBDA (CDENTRIES FN) (* ; "Edited 6-Sep-2020 15:58 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) DO (APPLY* FN CDE]) (CDENTRY [LAMBDA (MATCHNAME CDENTRIES) (* ; "Edited 5-Sep-2020 21:09 by rmk:") (ASSOC MATCHNAME (OR CDENTRIES LASTCDENTRIES]) (CDSUBSET [LAMBDA (CDENTRIES FN) (* ; "Edited 15-Sep-2020 13:49 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (CONS (CAR CDENTRIES) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) WHEN (APPLY* FN CDE) COLLECT CDE]) ) (DEFINEQ (BINCOMP [LAMBDA (FILE1 FILE2 EOLDIFFOK EOL1 EOL2) (* ; "Edited 13-Oct-2020 08:53 by rmk:") (* ;; "Returns T if FILE1 and FILE2 are byte-equivalent. Returns EOLDIFF if they are byte equivalent except for CR/LF/CRLF exchanges. ") (* ;; "If EOLDIFFOK, return indicates that the files are the same except for EOL mappings. If EOL1 and EOL2 are not provided, they are computed here.") (IF (IEQP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) THEN [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (* ;; "Simpler code to recompute eol's even if provided") (BIND B1 B2 EOL1 EOL2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS (AND EOLDIFFOK (SELCHARQ B1 (CR (CL:WHEN (EQ EOL1 'LF) (RETURN NIL)) (SETQ EOL1 'CR) (SETQ EOL2 'LF) (EQ B2 (CHARCODE LF))) (LF (CL:WHEN (EQ EOL1 'CR) (RETURN NIL)) (SETQ EOL1 'LF) (SETQ EOL2 'CR) (EQ B2 (CHARCODE CR))) NIL)) (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T] ELSEIF EOLDIFFOK THEN (* ;; "Lengths are different possibly because of CRLF to CR/LF substitutions.") (* ;;  "More complex code could detect the EOLTYPE incrementally without separate passes, but ...") (CL:UNLESS EOL1 (SETQ EOL1 (EOLTYPE FILE1))) (CL:UNLESS EOL2 (SETQ EOL2 (EOLTYPE FILE2))) (CL:WHEN (IF [AND (EQ EOL1 'CRLF) (MEMB EOL2 '(LF CR] ELSEIF [AND (EQ EOL2 'CRLF) (MEMB EOL1 '(LF CR] THEN (SWAP FILE1 FILE2)) (* ;; "FILE1 is now CRLF, FILE2 is not. If FILE1 isn't longer, it can't have a CRLF that corresponds to a CR or LF.") (CL:WHEN (IGREATERP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND B1 B2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS [AND (EQ (CHARCODE CR) B1) (EQ (CHARCODE LF) (\BIN STREAM1)) (MEMB B2 (CHARCODE (CR LF] (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T]))]) (EOLTYPE [LAMBDA (FILE SHOWCONTEXT) (* ; "Edited 21-Feb-2021 20:34 by rmk:") (* ;; "Returns the EOLCONVENTION of FILE if it only sees one kind, NIL if it can't decide.") (* ;; "If SHOWCONTEXT, it is the number of bytes before and after an EOL inconsistency (e.g. seeing CR after having seen LF) that will be displayed on the TTY. The position of the inconsistency will be marked with ##.") (SELECTQ SHOWCONTEXT (NIL) (T (SETQ SHOWCONTEXT 100)) (CL:UNLESS (FIXP SHOWCONTEXT) (ERROR "SHOWCONTEXT must be an integer" SHOWCONTEXT))) (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (SETFILEINFO STREAM 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND EOLTYPE DO (SELCHARQ (OR (\BIN STREAM) (RETURN EOLTYPE)) (CR (IF (EQ (CHARCODE LF) (\PEEKBIN STREAM T)) THEN (\BIN STREAM) (IF (MEMB EOLTYPE '(LF CR)) THEN (CL:UNLESS (EOLTYPE.SHOW SHOWCONTEXT EOLTYPE 'LF STREAM) (RETURN NIL)) ELSE (SETQ EOLTYPE 'CRLF)) ELSEIF (MEMB EOLTYPE '(LF CRLF)) THEN (CL:UNLESS (EOLTYPE.SHOW SHOWCONTEXT EOLTYPE 'CR STREAM) (RETURN NIL)) ELSE (SETQ EOLTYPE 'CR))) (LF (IF (MEMB EOLTYPE '(CR CRLF)) THEN (CL:UNLESS (EOLTYPE.SHOW SHOWCONTEXT EOLTYPE 'LF STREAM) (RETURN NIL)) ELSE (SETQ EOLTYPE 'LF))) NIL]) (EOLTYPE.SHOW [LAMBDA (SHOWCONTEXT OLDTYPE NEWTYPE STREAM) (* ; "Edited 21-Feb-2021 20:20 by rmk:") (* ;; "Returns T if we should continue") (CL:WHEN SHOWCONTEXT (LET ((FILEPOS (GETFILEPTR STREAM))) (COPYBYTES STREAM T (IDIFFERENCE FILEPOS SHOWCONTEXT) FILEPOS) (PRINTOUT T OLDTYPE "->" NEWTYPE " " FILEPOS T) (COPYBYTES STREAM T FILEPOS (IPLUS FILEPOS SHOWCONTEXT)) (TERPRI T) (CL:WHEN (EQ 'Y (ASKUSER NIL NIL "Continue? ")) (PRINTOUT T T "-------" T T) (SETFILEPTR STREAM FILEPOS) T)))]) ) (DECLARE%: EVAL@COMPILE (RECORD CDENTRY (MATCHNAME INFO1 DATEREL INFO2 . EQUIV)) (RECORD CDINFO (FULLNAME DATE LENGTH AUTHOR TYPE EOL)) ) (* ;; "look for compiled files older than the sources") (DEFINEQ (FIND-UNCOMPILED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 20-Sep-2020 23:04 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;; "Produces a list of the source files in FILES that have no corresponding compiled file") (* ;; "This determines whether there is at least one compiled file. If there are two or more, that's a problem") (* ;; "We want the most recent version only") (* ;; "Source files have a 2-element created-as with a non-NIL date") (SETQ FILES (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) UNLESS (MEMB (SETQ F (PACKFILENAME 'VERSION NIL 'BODY F)) $$VAL) COLLECT F)) (FOR F SCREATION FILES IN FILES WHEN (AND (CADR (SETQ SCREATION (CREATED-AS F))) (NOT (CDDR SCREATION))) WHEN [SETQ FILES (FOR CEXT CF IN (OR COMPILEEXTS *COMPILED-EXTENSIONS*) WHEN (SETQ CF (INFILEP (PACKFILENAME 'EXTENSION CEXT 'VERSION NIL 'BODY F))) COLLECT (CL:WHEN (SOURCE-FOR-COMPILED-P SCREATION CF DFASLMARGIN) (RETURN NIL)) CF FINALLY (* ;; "If we found some compiled files, they weren't on this source. If there weren't any compiled files to check, maybe there weren't any functions.") (* ;;  "NLSETQ because we don't want to stop if there is an error, typically from a package problem") (RETURN (OR $$VAL (LET [(FCOMS (CAR (NLSETQ (GETDEF (FILECOMS F) 'VARS F] (IF (NULL FCOMS) THEN (* ;;  "GETDEF caused an error. Maybe a package problem. ") (AND NIL 'NOCOMMANDS) ELSEIF (INFILECOMS? NIL '(FUNCTIONS FNS) FCOMS) THEN T] COLLECT (CONS F (SELECTQ FILES (T NIL) (NOCOMMANDS (CONS "No commands")) (FOR CF IN FILES COLLECT (* ;;  "Positive means that compiled is later than source, normal order but maybe by too much.") (* ;;  "Negative means that compiled came before source. Odd") (LIST CF (COMPILE-SOURCE-DATE-DIFF CF SCREATION]) (FIND-UNSOURCED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 15-Sep-2020 15:32 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;;  "Produces a list of compiled FILES for which no source file can be found in the same directory.") (* ;; "The source date in at least one DFASL was off by a second, maybe some sort of IDATE rounding? So, give a margin.") (* ;; "We want the most recent version only. Check CREATED-AS to make sure it really is a compiled file.") (* ;; "Sort to get lcoms and dfasls next to each other.") (LET (CCREATEDS) (SETQ CCREATEDS (FOR CEXT FOUND CCREATED INSIDE (OR COMPILEEXTS *COMPILED-EXTENSIONS*) JOIN (FOR CF IN [OR (LISTP FILES) (FILDIR (PACKFILENAME 'EXTENSION CEXT 'VERSION "" 'BODY '*] WHEN (CDDR (SETQ CCREATED (CREATED-AS CF))) UNLESS (MEMBER CCREATED $$VAL) COLLECT CCREATED))) (* ;; "CCREATEDS is now a list of CREATED-AS items") (FOR CC SF IN CCREATEDS UNLESS (AND [SETQ SF (INFILEP (PACKFILENAME 'EXTENSION NIL 'VERSION NIL 'BODY (CAR CC] (SOURCE-FOR-COMPILED-P (SETQ SF (CREATED-AS SF)) CC DFASLMARGIN)) COLLECT [LIST (CAR CC) (AND SF (LIST (CAR SF) (ROUND (COMPILE-SOURCE-DATE-DIFF CC SF] FINALLY (RETURN (SORT $$VAL (FUNCTION (LAMBDA (CF1 CF2) (ALPHORDER (FILENAMEFIELD (CAR CF1) 'NAME) (FILENAMEFIELD (CAR CF2) 'NAME]) (FIND-SOURCE-FILES [LAMBDA (CFILES SDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (CFILE . SFILES) pairs where CFILE is a Lisp compiled file in CFILES SFILES is a list of source files in SDIRS that CFILE was compiled on.") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ SDIRS (FOR SD INSIDE (OR SDIRS T) COLLECT (DIRECTORYNAME SD))) (SORT (FOR CF SFILES CNAME CCREATED IN (OR (LISTP CFILES) (FILDIR CFILES)) WHEN (AND (SETQ CNAME (INFILEP CF)) (CDDR (SETQ CCREATED (CREATED-AS CF))) (SETQ SFILES (FOR SD SF IN SDIRS WHEN (AND (SETQ SF (INFILEP (PACKFILENAME 'NAME (FILENAMEFIELD CF 'NAME) 'BODY SD))) (SOURCE-FOR-COMPILED-P SF CCREATED DFASLMARGIN)) COLLECT SF))) COLLECT (CONS CNAME SFILES)) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-COMPILED-FILES [LAMBDA (SFILES CDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (SFILE . CFILES) pairs where SFILE is a Lisp source file in SFILES CFILES is a list of compiled files in CDIRS that were compiled on SFILE.") (* ;; "FILEDATE is true for source files and compiled files") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ CDIRS (FOR CD INSIDE (OR CDIRS T) COLLECT (DIRECTORYNAME CD))) (SORT (FOR SF CFILES SNAME SCREATED IN (OR (LISTP SFILES) (FILDIR SFILES)) WHEN [AND (SETQ SNAME (INFILEP SF)) (SETQ SCREATED (CREATED-AS SF)) (NOT (CDDR SCREATED)) (SETQ CFILES (FOR CEXT (ROOT _ (FILENAMEFIELD SNAME 'NAME)) IN *COMPILED-EXTENSIONS* JOIN (FOR CD CF IN CDIRS WHEN (AND (SETQ CF (INFILEP (PACKFILENAME 'NAME ROOT 'EXTENSION CEXT 'BODY CD))) (SOURCE-FOR-COMPILED-P SCREATED CF DFASLMARGIN)) COLLECT CF] COLLECT (CONS SNAME CFILES )) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-UNLOADED-FILES [LAMBDA (FILES) (* ; "Edited 9-Sep-2020 19:35 by rmk:") (* ;; "Returns the files in FILES that don't have FILECREATED properties and presumably are therefore not loaded in the current sysout.") (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (AND (SETQ F (INFILEP (CL:IF (LISTP F) (CAR F) F))) (FILEDATE F)) UNLESS (GETP (FILENAMEFIELD F 'NAME) 'FILEDATES) COLLECT F]) (FIND-LOADED-FILES [LAMBDA (ROOTFILENAMES) (* ; "Edited 19-Sep-2020 07:20 by rmk:") (FOR RN INSIDE ROOTFILENAMES WHEN (GETP RN 'FILEDATES) COLLECT (CONS RN (FOR F IN LOADEDFILELST WHEN (EQ RN (FILENAMEFIELD F 'NAME)) COLLECT F]) (FIND-MULTICOMPILED-FILES [LAMBDA (FILES SHOWINFO) (* ; "Edited 20-Sep-2020 20:57 by rmk:") (* ;; "Returns a list of names for files in FILES that have multiple compilations") (LET (SFILES) (FOR F EXT NAME IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (MEMB (SETQ EXT (FILENAMEFIELD F 'EXTENSION)) *COMPILED-EXTENSIONS*) DO (SETQ NAME (FILENAMEFIELD F 'NAME)) (* ;; "PUSHNEW because we haven't filtered out versions") (PUSHNEW [CDR (OR (ASSOC NAME SFILES) (CAR (PUSH SFILES (CONS NAME] EXT)) (FOR S IN SFILES WHEN (CDDR S) COLLECT (IF SHOWINFO THEN `[,(CAR S) ,(CADAR (FIND-LOADED-FILES (CAR S))) ,(CREATED-AS (CAR S)) ,@(FOR EXT IN (SORT (CDR S)) COLLECT (CREATED-AS (PACKFILENAME 'EXTENSION EXT 'BODY (CAR S] ELSE (CAR S]) ) (DEFINEQ (CREATED-AS [LAMBDA (FILE) (* ; "Edited 20-Sep-2020 23:06 by rmk:") (* ;; "For lisp source files, returns (filecreatename filecreateddate)") (* ;; "For lisp compiled files, returns (cfilename cfiledate sfilecreatename sfilecreateddate)") (* ;; "For other files, (fullfilename NIL)") (* ;; "The cfilename is just the current directory name for DFASLs.") (* ;; "So: (CADR value) is non-NIL for Lisp files. Of those, (CDDR value) is non-NIL for compiled files.") (* ;; "We disable the package delimiter because the atoms in changes may have a packages that we don't know.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (LET (FILEDATE FILENAME SOURCEDATE SOURCENAME LINE POS) [IF (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) THEN (* ; "Managed source or LCOM") (RESETLST [LET (FORM SFORM (RDTBL (FIND-READTABLE "OLD-INTERLISP-FILE"))) (SETQ POS (GETFILEPTR STREAM)) (READCCODE STREAM) (IF (EQ 'DEFINE-FILE-INFO (RATOM STREAM RDTBL)) THEN (* ;; "Reading is package-safe") (SETFILEPTR STREAM POS) (SETQ FORM (READ STREAM RDTBL)) (SETQ RDTBL (FIND-READTABLE (LISTGET (CDR FORM) :READTABLE))) ELSE (SETFILEPTR STREAM POS)) (CL:WHEN (EQ 'PACKAGEDELIM (GETSYNTAX '%: RDTBL)) [RESETSAVE (SETSYNTAX '%: 'OTHER RDTBL) `(SETSYNTAX %: PACKAGEDELIM ,RDTBL]) (* ;; "One way or the other, we're ready for the filecreated") (CL:WHEN (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (SETQ FORM (READ STREAM RDTBL)) (CL:WHEN (MEMB (U-CASE (CAR FORM)) '(FILECREATED IL%:FILECREATED)) (* ;; "IL%%:FILECREATED because we screwed the readtable.") (IF [STREQUAL "compiled on " (CAR (LISTP (CADDR FORM] THEN (* ; "LCOM, get source info") (IF [AND (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (MEMB [U-CASE (CAR (SETQ SFORM (READ STREAM RDTBL] '(FILECREATED IL%:FILECREATED] THEN (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM)) (SETQ SOURCENAME (CADDR SFORM)) (SETQ SOURCEDATE (CADR SFORM)) ELSE (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM))) ELSE (SETQ FILENAME (CADDR FORM)) (SETQ FILEDATE (CADR FORM)))))]) ELSEIF (SETQ POS (STRPOS "XCL Compiler output for source file " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) THEN (* ; "DFASL compiled?") (SETQ SOURCENAME (SUBATOM LINE POS)) (CL:WHEN (SETQ POS (STRPOS "Source file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ SOURCEDATE (GDATE (IDATE (SUBSTRING LINE POS] (CL:WHEN (SETQ POS (STRPOS "FASL file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ FILEDATE (GDATE (IDATE (SUBSTRING LINE POS]))] (* ;; "Revert filenames to Interlisp package if needed:") (CL:WHEN (STRPOS "IL:" FILENAME) (SETQ FILENAME (SUBATOM FILENAME 4))) (CL:WHEN (STRPOS "IL:" SOURCENAME) (SETQ SOURCENAME (MKATOM SOURCENAME 4))) (* ;; "Return DATE NIL if file is not a Lisp file") `(,(OR FILENAME (FULLNAME STREAM)) ,(AND FILEDATE (GDATE (IDATE FILEDATE))) ,@(CL:WHEN SOURCENAME (LIST SOURCENAME (GDATE (IDATE SOURCEDATE))))]) (SOURCE-FOR-COMPILED-P [LAMBDA (SOURCE COMPILED DFASLMARGIN) (* ; "Edited 31-Oct-2020 09:12 by rmk:") (* ;; "There seems to be some variation between the source dates in dfasl files and the filecreated date in the sources, they often don't match exactly. But if they are within DFASLMARGIN, we assume a match. We require exact date match for LCOMS") (* ;; "This is needed for dfasl files created before they recorded the source filecreated name and date instead of the directory source name and date when compile took place.") (* ;; "") (* ;; "DFASLMARGIN is a pair (after before) where we assume a match if the compiled date is no more than after minutes after the source date and no more than before minuts before (the diff is negative then).") (* ;; "A single positive integer x is interpreted as (x 0). A single negative integer x is interpreted as (-x x) (before or after x).") (* ;; "Default is (20 0).") (* ;; "T is positive or negative infinity") (CL:UNLESS (LISTP SOURCE) (SETQ SOURCE (CREATED-AS SOURCE))) (CL:UNLESS (LISTP COMPILED) (SETQ COMPILED (CREATED-AS COMPILED))) (SETQ DFASLMARGIN (IF (NULL DFASLMARGIN) THEN (* ;;  "If compiled is later than source by less than 20 minutes, it's probably OK") '(20 0) ELSEIF (EQ T DFASLMARGIN) THEN '(T 0) ELSEIF (LISTP DFASLMARGIN) ELSEIF (NOT (FIXP DFASLMARGIN)) THEN (ERROR "ILLEGAL DFASLMARGIN" DFASLMARGIN) ELSEIF (MINUSP DFASLMARGIN) THEN (LIST (MINUS DFASLMARGIN) DFASLMARGIN) ELSE (LIST DFASLMARGIN 0))) (OR (EQUAL (CAR SOURCE) (CADDR COMPILED)) (EQUAL (CADR SOURCE) (CADDDR COMPILED)) (AND [EQ 'DFASL (U-CASE (FILENAMEFIELD (CAR COMPILED) 'EXTENSION] (LET ((TIMEDIFF (COMPILE-SOURCE-DATE-DIFF COMPILED SOURCE))) (* ;; "If compiled was no more than 20 minutes later, it's probably OK. Of no more than DFASLMARGIN earlier, if it is negative.") (AND (OR (EQ T (CAR DFASLMARGIN)) (LEQ TIMEDIFF (CAR DFASLMARGIN))) (OR (EQ T (CADR DFASLMARGIN)) (GEQ TIMEDIFF (CADR DFASLMARGIN]) (COMPILE-SOURCE-DATE-DIFF [LAMBDA (CFILE SFILE) (* ; "Edited 20-Sep-2020 22:59 by rmk:") (* ;; "Positive means that compiled is later than source, normal order but maybe by too much. Negative means that compiled came before source, i.e., compiled on a source that didn't yet exist.") (* ;; "Value is in minutes") (ROUND (FQUOTIENT [IDIFFERENCE [IDATE (CADDDR (OR (LISTP CFILE) (CREATED-AS CFILE] (IDATE (CADR (OR (LISTP SFILE) (CREATED-AS SFILE] (TIMES 60 ONESECOND]) ) (DEFINEQ (FIX-DIRECTORY-DATES [LAMBDA (FILES MARGIN) (* ; "Edited 30-Oct-2020 22:01 by rmk:") (* ;; "For Lisp source and compiled files, ensures that the directory file date corresponds to the filecreated date. Returns the list of files whose dates were changed.") (* ;; "This allows for the fact that directory dates that are no later than, say, 30 seconds of the filecreated date are probably OK--the directory date may be set when the file is closed.") (* ;; "Use IDATEs in case FDCDATE is not Y2K.") (* ;; "Stop if directory date is more than 2 minutes earlier than the filecreated date. Earlier could be because the dates are asserted at different points in the filing process. But 2 minutes is worth thinking about. Returning from HELP will get them aligned.") (SETQ MARGIN (ITIMES (OR MARGIN 2) 60 ONESECOND)) (FOR F DIDATE FCDATE IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (SETQ FCDATE (FILEDATE F)) UNLESS (IEQP (SETQ DIDATE (GETFILEINFO F 'ICREATIONDATE)) (SETQ FCDATE (IDATE FCDATE))) COLLECT (CL:WHEN (IGREATERP (IDIFFERENCE FCDATE DIDATE) MARGIN) (HELP "DIRECTORY DATE EARLIER THAN FILECREATED DATE" (LIST F (GDATE DIDATE) (GDATE FCDATE)))) (SETFILEINFO F 'ICREATIONDATE FCDATE) F]) (FIX-EQUIV-DATES [LAMBDA (CDENTRIES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "For every entry whose files are EQUIVALENT and whose filedates are different, sets the directory of the file with the later date to be the date of the one with the earlier date. This preumes that the later one must have been a copy. ") (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE EARLY LATE IN (CDR CDENTRIES) WHEN (FETCH EQUIV OF CDE) UNLESS (EQ '= (FETCH DATEREL OF CDE)) COLLECT (SELECTQ (FETCH DATEREL OF CDE) (> (SETQ EARLY (FETCH INFO2 OF CDE)) (SETQ LATE (FETCH INFO1 OF CDE))) (< (SETQ EARLY (FETCH INFO1 OF CDE)) (SETQ LATE (FETCH INFO2 OF CDE))) (SHOULDNT)) (SETFILEINFO (FETCH FULLNAME OF LATE) 'ICREATIONDATE (GETFILEINFO (FETCH FULLNAME OF EARLY) 'ICREATIONDATE)) (FETCH FULLNAME OF LATE]) (COPY-COMPARED-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:20 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO MATCHNAME IN (CDR CDENTRIES) EACHTIME (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) WHEN (AND (FETCH FULLNAME OF SINFO) (FETCH FULLNAME OF TINFO)) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'VERSION NIL 'BODY (FETCH FULLNAME OF TINFO))) MATCHNAME]) (COPY-MISSING-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (CL:UNLESS (STRINGP (CADR (CAR CDENTRIES))) (ERROR "(CAR CDENTRIES) IS NOT A VALID PARAMETER LIST" (CAR CDENTRIES))) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO TDIR MATCHNAME (TDIR _ (CL:IF (EQ TARGET 1) (CAAR CDENTRIES) (CADAR CDENTRIES))) IN (CDR CDENTRIES) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) WHEN (AND (FETCH FULLNAME OF SINFO) (NOT (FETCH FULLNAME OF TINFO))) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (* ;; "Using the source fullname in the target should preserve the version number") (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'BODY TDIR 'BODY (FETCH FULLNAME OF SINFO))) MATCHNAME]) (COMPILED-ON-SAME-SOURCE [LAMBDA (CDENTRIES) (* ; "Edited 9-Sep-2020 13:00 by rmk:") (* ;; "Returms a subset of CDENTRIES consisting of files that are compiled on the same source (i.e. their source names or dates are the same). Preserves the header.") (CDSUBSET CDENTRIES (FUNCTION (LAMBDA (CDE) (DECLARE (USEDFREE INFO1 INFO2)) (LET (CREATED1 CREATED2) (CL:WHEN [AND (EQ 'COMPILED (FETCH TYPE OF INFO1)) (EQ 'COMPILED (FETCH TYPE OF INFO2)) [CDDR (SETQ CREATED1 (CREATED-AS (FETCH FULLNAME OF INFO1] (CDDR (SETQ CREATED2 (CREATED-AS (FETCH FULLNAME OF INFO2] (OR (EQUAL (CADDR CREATED1) (CADDR CREATED2)) (EQUAL (CADDDR CREATED1) (CADDDR CREATED2))))]) ) (RPAQ ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"))) (RPAQ? LASTCDENTRIES NIL) (DEFINEQ (COMPARE-ENTRY-SOURCE-FILES [LAMBDA (CDENTRY LISTSTREAM EXAMINE DW?) (* ; "Edited 30-Aug-2020 12:22 by rmk:") (* ;; "Wrapper to call COMPARESOURCES on the Lisp source files of CDENTRY") (CL:WHEN [AND (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO1 OF CDENTRY))) (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO2 OF CDENTRY] (COMPARESOURCES (FETCH FULLNAME OF (FETCH INFO1 OF CDENTRY)) (FETCH FULLNAME OF (FETCH INFO2 OF CDENTRY)) EXAMINE DW? LISTSTREAM))]) ) (FILESLOAD COMPARESOURCES) (PUTPROPS COMPAREDIRECTORIES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1994 1998 2018 2020 2021)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1712 17919 (COMPAREDIRECTORIES 1722 . 10949) (CDFILES 10951 . 15526) ( COMPAREDIRECTORIES.INFOS 15528 . 17043) (MATCHNAME 17045 . 17478) (MEDLEY-FIX-DIRS 17480 . 17917)) ( 18092 25299 (CDPRINT 18102 . 22902) (CDPRINT.LINE 22904 . 25297)) (25300 27052 (CDMAP 25310 . 26006) ( CDENTRY 26008 . 26176) (CDSUBSET 26178 . 27050)) (27053 33994 (BINCOMP 27063 . 31352) (EOLTYPE 31354 . 33319) (EOLTYPE.SHOW 33321 . 33992)) (34207 47414 (FIND-UNCOMPILED-FILES 34217 . 37860) ( FIND-UNSOURCED-FILES 37862 . 40671) (FIND-SOURCE-FILES 40673 . 42377) (FIND-COMPILED-FILES 42379 . 44457) (FIND-UNLOADED-FILES 44459 . 45203) (FIND-LOADED-FILES 45205 . 45759) (FIND-MULTICOMPILED-FILES 45761 . 47412)) (47415 55617 (CREATED-AS 47425 . 52222) (SOURCE-FOR-COMPILED-P 52224 . 54922) ( COMPILE-SOURCE-DATE-DIFF 54924 . 55615)) (55618 64597 (FIX-DIRECTORY-DATES 55628 . 57596) ( FIX-EQUIV-DATES 57598 . 58858) (COPY-COMPARED-FILES 58860 . 60984) (COPY-MISSING-FILES 60986 . 62825) (COMPILED-ON-SAME-SOURCE 62827 . 64595)) (64752 65363 (COMPARE-ENTRY-SOURCE-FILES 64762 . 65361))))) STOP \ No newline at end of file diff --git a/lispusers/COMPAREDIRECTORIES.LCOM b/lispusers/COMPAREDIRECTORIES.LCOM index 7a669cbf..7acbaa7d 100644 Binary files a/lispusers/COMPAREDIRECTORIES.LCOM and b/lispusers/COMPAREDIRECTORIES.LCOM differ diff --git a/lispusers/COMPAREDIRECTORIES.LCOM.~270~ b/lispusers/COMPAREDIRECTORIES.LCOM.~270~ deleted file mode 100644 index c63c4948..00000000 Binary files a/lispusers/COMPAREDIRECTORIES.LCOM.~270~ and /dev/null differ diff --git a/lispusers/COMPAREDIRECTORIES.LCOM.~274~ b/lispusers/COMPAREDIRECTORIES.LCOM.~274~ deleted file mode 100644 index 5cc3ff18..00000000 Binary files a/lispusers/COMPAREDIRECTORIES.LCOM.~274~ and /dev/null differ diff --git a/lispusers/COMPAREDIRECTORIES.TEDIT b/lispusers/COMPAREDIRECTORIES.TEDIT index 9854a8ac..c5528d16 100644 --- a/lispusers/COMPAREDIRECTORIES.TEDIT +++ b/lispusers/COMPAREDIRECTORIES.TEDIT @@ -1,4 +1,4 @@ -XEROX COMPAREDIRECTORIES 2 4 1 COMPAREDIRECTORIES 1 4 By: Larry Masinter and Ron Kaplan This document edited on December 2, 1987 December 28, 1998 (Ron Kaplan) April 7, 2018 (Ron Kaplan) Rewritten August 25, 2020 (Ron Kaplan) COMPAREDIRECTORIES compares the contents of two directories, identifying files according to their creation dates and lengths. It is called using the function (COMPAREDIRECTORIES DIR1 DIR2 SELECT FILEPATTERNS EXTENSIONSTOAVOID USEDIRECTORYDATES OUTPUTFILE ALLVERSIONS) [Function] Compares the creation dates of files with matching names in the lists that CDFILES returns for DIR1 and DIR2. Collects or prints CDENTRIES for those files that meet the SELECT criteria. May also collect or print entries for relevant files that exist in DIR1 or DIR2 but not both. SELECT specifies which the match/mismatch criteria for filtering the output. If SELECT is or contains AFTER or >: select entries where file1 has a later date than file2 BEFORE or <: select entries where file1 has an earlier date than file2 SAMEDATE or =: select entries where file1 and file2 have the same date -*: exclude entries where file1 does not exist *-: exclude entries where file2 does not exist ~=: exclude entries where file1 and file2 are byte-equivalent SELECT = NIL is equivalent to (< > -* *-). Excludes files with matching dates, a useful default for identifying files that may require further attention. SELECT = T is equivalent to (= < > -* *-). Includes all files for processing by other functions or later filtering by CDSUBSET (below). SELECT may also contain the token AUTHOR to indicate that authors should be provided in the printed output (see CDPRINT below). Unless USEDIRECTORYDATES, the FILECREATED date is used for the date comparison of Lisp source and compiled files, otherwise the file-system CREATIONDATE is used. If OUTPUTFILE=NIL, then a list of the form (Parameters . entries) is returned. Parameters is a list (DIR1 DIR2 SELECT DATE) that records the parameters of the comparison. Entries contains one entry for each of the file-comparisons that meets the SELECT criteria. Each entry is a CDENTRY record with fields (matchname info1 daterel info2 equiv) where matchname is the name.extension shared by the two files, and each file info is either NIL (for nonexistent files) or a CDINFO record with fields (fullfilename date length author type eol) type is SOURCE for Lisp source (filecreated) files, COMPILED for Lisp compiled files, otherwise the PRINTFILETYPE (TEXT, TEDIT...) or NIL. eol is CR, LF, CRLF, or NIL. When both files exist, the date relation is one of <, =, or >. Otherwise, the date relation is * if only one file exists. EQUIV is EQUIVALENT for files with different dates but exactly the same bytes, otherwise NIL. If OUTPUTFILE is not NIL, then it is a filename or open stream on which selected entries will be printed (T for the terminal) by CDPRINT. COMPAREDIRECTORIES sets the variable LASTCDENTRIES is set to the selected entries. This is used by the functions below if their CDENTRIES is NIL. (CDFILES DIR FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH) [Function] Returns a list of full filenames for files in directory DIR (NIL=T=the connected directory) that match the other file-name filtering criteria. Files are excluded if: Their name does not match a pattern in FILEPATTERNS (NIL = *). Dotted files are excluded unless FILEPATTERNS includes .* and files in subdirectories are excluded if the number of subdirectories exceeds DEPTH (below). Their extension is in the list EXTENSIONSTOAVOID (* excludes all extensions). They are not the highest version unless ALLVERSIONS=T. DEPTH controls the depth of subdirectory exploration. T means all levels, NIL means no subdirectories. Otherwise the maximum number of ">" characters below the starting DIR in the fullname of files. (CDFILES) produces all the newest, undotted files in the immediate connected directory. (CDPRINT CDENTRIES FILE PRINTAUTHOR) [Function] Prints CDENTRIES on FILE, with one line for each entry. The line for each entry is of the form FILE1 (AUTHOR) SIZE DATE relation DATE FILE2 (AUTHOR) SIZE For example ACE.;1 (Joe) 4035 2-May-1985 18:03:54 < 30-Sep-1985 11:14:48 ACE.;3 (Sam) 5096. The line for byte-equivalent files is prefixed with ==. If the files are equivalent except for a difference in end-of-line conventions, the equivalence prefix will indicate the convention for each file (C for CR, L, for LF, 2 for CRLF). Thus C2 indicates that the files are equivalent except that file1 marks line ends with CR and file2 with CRLF. Note that because of the setting of LASTCDENTRIES, evaluating (CDPRINT) after COMPAREDIRECTORIES prints the results of the last comparision. For conciseness, authors are included only if PRINTAUTHOR or if AUTHOR is included in the SELECT parameter of CDENTRIES. Also, the redundant file-name hosts/directories are not printed. (CDMAP CDENTRIES FN) [Function] (CDSUBSET CDENTRIES FN) [Function] CDMAP applies FN to each CDENTRY in CDENTRIES. CDSUBSET applies FN and also returns the subset of CDENTRIES for which FN is non-NIL and preserves in the value the parameters of CDENTRIES. For convenience, at each invocation the variables MATCHNAME INFO1 DATEREL INFO2 and EQUIV are bound to the corresponding fields and can be used freely by FN. USEFUL UTILITIES (FIX-DIRECTORY-DATES FILES) [Function] For every file included in or specified by FILES, if it is a Lisp source or compiled whose directory creation date is more than 30 seconds later than its internal filecreated date (presumably because of copying), then its directory date is reset to match the internal date. FILES can be a list of file names or a pattern interpretable by FILDIR. Returns a list of files whose dates have been changed. (FIX-EQUIV-DATES CDENTRIES) [Function] If there is an entry in CDENTRIES whose files are EQUIVALENT but with different directory creation dates, the directory date of the file with the later date (presumably a copy) is reset to match the date of the earlier file. In the end all equivalent files will have the same (earliest) date. Returns a list of files whose dates have been changed. (COPY-MISSING-FILES CDENTRIES TARGET MATCHNAMES) [Function] Target is 1 or 2, indicating the direction of potential copies. If an entry with a source file but no target file has a matchname in MATCHNAMES, the source file is copied to the target directory. All target-absent files are copied if MATCNAMES is NIL. Source properties (including version number) are preserved in the target. (COPY-COMPARED-FILES CDENTRIES TARGET MATCHNAMES) [Function] Target is 1 or 2, indicating the direction of potential copies. If an entry with both source and target files has a matchname in MATCHNAMES, the source file is copied to a new version of the target file. All files are copied if MATCHNAMES is NIL. (COMPARE-ENTRY-SOURCE-FILES CDENTRY LISTSTREAM EXAMINE DW?) [Function] This is a simple wrapper for calling COMPARESOURCES if the CDENTRY files are Lisp source files. The function (CDENTRY MATCHNAME CDENTRIES is useful for extracting a particular entry, with CDENTRIES defaulting to LASTCDENTRIES. (COMPILED-ON-SAME-SOURCE CDENTRIES) [Function] Returns the subset of entries with Lisp compiled files (dfasl or lcom) that are compiled on the same source, according to SOURCE-FOR-COMPILED-P below. Presumably one should be removed to avoid confusion. (FIND-SOURCE-FILES CFILES SDIRS DFASLMARGIN) [Function] Returns (CFILE . SFILES) pairs where CFILE is a Lisp compiled file in CFILES and SFILES is list of files in SDIRS that CFILE was compiled on according to SOURCE-FOR-COMPILED-P. This suggests that at least one of SFILES should be copied to CFILE's location (or vice versa). (FIND-COMPILED-FILES SFILES CDIRS DFASLMARGIN) [Function] Returns (SFILE . CFILES) pairs where SFILE is a Lisp source file in SFILES and CFILES are files in CDIRS that are compiled on SFILE according to SOURCE-FOR-COMPILED-P. This suggests that at least one of CFILES should be copied to SFILE's location. (FIND-UNCOMPILED-FILES FILES DFASLMARGIN COMPILEXTS) [Function] Returns a list of elements each of which corresponds to a source file in FILES for which no appropriate compiled file can be found. An appropriate compiled file is a file in the same location with extension in COMPILEEXTS (defaulting to *COMPILED-EXTENSIONS*) that satisfies SOURCE-FOR-COMPILED-P. Each element is a list of the form (sourcefile . cfiles) cfiles contains compiled files that were compiled on a different version of sourcefile, NIL if no such files exist. Each cfile item is a pair (cfile timediff) where timediff is the time difference (in minutes) between the creation date of the compiled-file's source and the creation date of sourcefile (positive if the cfile was compiled later, as should be the case). FILES can be an explicit list of files, or a file specification interpretable by FILDIR; in that case only the newest source-file versions are processed. (FIND-UNSOURCED-FILES CFILES DFASLMARGIN COMPILEXTS) [Function] Returns the subset of the compiled files specified by CFILES for which a corresponding source file according to SOURCE-FOR-COMPILED-P cannot be found in the same directory. CFILES can be a list of files or a pattern that FILDIR can interpret. COMPILEEXTS can be one or more explicit compile-file extensions, defaulting to *COMPILED-EXTENSIONS*. (SOURCE-FOR-COMPILED-P SOURCE COMPILED DFASLMARGIN) [Function] Returns T if it can confirm that Lisp COMPILED file was compiled on Lisp SOURCE file. SOURCE and COMPILED can be provided as CREATED-AS values, to avoid repetitive computation. This compares the information in the filecreated expressions, original file names and original dates, and not the current directory names and dates. It appears that the times in DFASL files may differ from the filecreated source dates by a few minutes. The DFASLMARGIN can be provided to loosen up the date matching criterion. DFASLMARGIN is a pair (max min) and a DFASL COMPILED is deemed to be compiled on SOURCE if the compiled's source date is no more than max and no less than min minutes after the source date. A negative min allows for the possibility that the compiled-source date is earlier than the candidate source date. DFASLMARGIN defaults to (20 0). A single positive number x is coerced to (x 0). A single negative number is coerced to (-x x) (compiled file is no more than x minutes later or earlier). T is infinity in either direction. Examples: (T 0): COMPILED compiled on source later than SOURCE (0 T): COMPILED compiled on source earlier than SOURCE (odd) 12: COMPILED compiled on source later than SOURCE by no more than 12 minutes -12: COMPILED compiled on source 12 minutes before or after SOURCE (FIND-MULTICOMPILED-FILES FILES SHOWINFO) [Function] Returns a list of files in FILES that have more than one type of compiled file (e.g. LCOM and DFASL). FILES is interpretable by FILDIR. If SHOWINFO, then the value contains a list for each file of the form ÿÿï!ÿ(rootname loaded-version . CREATED-AS information for each compile-type) Otherwise just the rootname of the source is returns. (CREATED-AS FILE) [Function] If FILE is a Lisp source or compiled file, returns a record of its original filename and filecreated dates, and for compiled files, also the original compiled-on name and date. The return for a source file is a pair (sfullname sfilecreateddate) The return for a compiled file is a quadruple (cfullname cfilecreated sfullname sfilecreateddate) where sfullname and sourcefilecreated are extracted from the file's compiled-on information. The return is (fullname NIL) for a non-Lisp file. (EOLTYPE FILE) [Function] Returns the EOLTYPE of FILE (CR, LF, CRLF) if the type is unmistakable: contains at least one instance of one type and no instances of any others. (BINCOMP FILE1 FILE2 EOLDIFFOK) [Function] Returns T if FILE1 and FILE2 are byte-identical. If EOLDIFFOK and FILE1 and FILE2 differ only in their eol conventions, the value is a list of the form (EOL1 EOL2), e.g. (CR CRLF). Otherwise the value is NIL. (LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC) STARTINGPAGE# 1) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))))) 4ÈÈ40ÈÈ4 ÈÈ4ÈÈ.4@È4ÈÈ.È.ŠŠ8.ŠŠ8JÈÈ PAGEHEADING RUNNINGHEAD. +XEROX COMPAREDIRECTORIES 2 4 1 COMPAREDIRECTORIES 1 4 By: Larry Masinter and Ron Kaplan This document edited on December 2, 1987 December 28, 1998 (Ron Kaplan) April 7, 2018 (Ron Kaplan) Rewritten August 25, 2020 (Ron Kaplan) COMPAREDIRECTORIES compares the contents of two directories, identifying files according to their creation dates and lengths. It is called using the function (COMPAREDIRECTORIES DIR1 DIR2 SELECT FILEPATTERNS EXTENSIONSTOAVOID USEDIRECTORYDATES OUTPUTFILE ALLVERSIONS) [Function] Compares the creation dates of files with matching names in the lists that CDFILES returns for DIR1 and DIR2. Collects or prints CDENTRIES for those files that meet the SELECT criteria. May also collect or print entries for relevant files that exist in DIR1 or DIR2 but not both. SELECT specifies which the match/mismatch criteria for filtering the output. If SELECT is or contains AFTER or >: select entries where file1 has a later date than file2 BEFORE or <: select entries where file1 has an earlier date than file2 SAMEDATE or =: select entries where file1 and file2 have the same date -*: exclude entries where file1 does not exist *-: exclude entries where file2 does not exist ~=: exclude entries where file1 and file2 are byte-equivalent SELECT = NIL is equivalent to (< > -* *-). Excludes files with matching dates, a useful default for identifying files that may require further attention. SELECT = T is equivalent to (= < > -* *-). Includes all files for processing by other functions or later filtering by CDSUBSET (below). SELECT may also contain the token AUTHOR to indicate that authors should be provided in the printed output (see CDPRINT below). Unless USEDIRECTORYDATES, the FILECREATED date is used for the date comparison of Lisp source and compiled files, otherwise the file-system CREATIONDATE is used. If OUTPUTFILE=NIL, then a list of the form (Parameters . entries) is returned. Parameters is a list (DIR1 DIR2 SELECT DATE) that records the parameters of the comparison. Entries contains one entry for each of the file-comparisons that meets the SELECT criteria. Each entry is a CDENTRY record with fields (matchname info1 daterel info2 equiv) where matchname is the name.extension shared by the two files, and each file info is either NIL (for nonexistent files) or a CDINFO record with fields (fullfilename date length author type eol) type is SOURCE for Lisp source (filecreated) files, COMPILED for Lisp compiled files, otherwise the PRINTFILETYPE (TEXT, TEDIT...) or NIL. eol is CR, LF, CRLF, or NIL. When both files exist, the date relation is one of <, =, or >. Otherwise, the date relation is * if only one file exists. EQUIV is EQUIVALENT for files with different dates but exactly the same bytes, otherwise NIL. If OUTPUTFILE is not NIL, then it is a filename or open stream on which selected entries will be printed (T for the terminal) by CDPRINT. COMPAREDIRECTORIES sets the variable LASTCDENTRIES is set to the selected entries. This is used by the functions below if their CDENTRIES is NIL. (CDFILES DIR FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH) [Function] Returns a list of full filenames for files in directory DIR (NIL=T=the connected directory) that match the other file-name filtering criteria. Files are excluded if: Their name does not match a pattern in FILEPATTERNS (NIL = *). Dotted files are excluded unless FILEPATTERNS includes .* and files in subdirectories are excluded if the number of subdirectories exceeds DEPTH (below). Their extension is in the list EXTENSIONSTOAVOID (* excludes all extensions). They are not the highest version unless ALLVERSIONS=T. DEPTH controls the depth of subdirectory exploration. T means all levels, NIL means no subdirectories. Otherwise the maximum number of ">" characters below the starting DIR in the fullname of files. (CDFILES) produces all the newest, undotted files in the immediate connected directory. (CDPRINT CDENTRIES FILE PRINTAUTHOR) [Function] Prints CDENTRIES on FILE, with one line for each entry. The line for each entry is of the form FILE1 (AUTHOR) SIZE DATE relation DATE FILE2 (AUTHOR) SIZE For example ACE.;1 (Joe) 4035 2-May-1985 18:03:54 < 30-Sep-1985 11:14:48 ACE.;3 (Sam) 5096. The line for byte-equivalent files is prefixed with ==. If the files are equivalent except for a difference in end-of-line conventions, the equivalence prefix will indicate the convention for each file (C for CR, L, for LF, 2 for CRLF). Thus C2 indicates that the files are equivalent except that file1 marks line ends with CR and file2 with CRLF. Note that because of the setting of LASTCDENTRIES, evaluating (CDPRINT) after COMPAREDIRECTORIES prints the results of the last comparision. For conciseness, authors are included only if PRINTAUTHOR or if AUTHOR is included in the SELECT parameter of CDENTRIES. Also, the redundant file-name hosts/directories are not printed. (CDMAP CDENTRIES FN) [Function] (CDSUBSET CDENTRIES FN) [Function] CDMAP applies FN to each CDENTRY in CDENTRIES. CDSUBSET applies FN and also returns the subset of CDENTRIES for which FN is non-NIL and preserves in the value the parameters of CDENTRIES. For convenience, at each invocation the variables MATCHNAME INFO1 DATEREL INFO2 and EQUIV are bound to the corresponding fields and can be used freely by FN. USEFUL UTILITIES (FIX-DIRECTORY-DATES FILES) [Function] For every file included in or specified by FILES, if it is a Lisp source or compiled whose directory creation date is more than 30 seconds later than its internal filecreated date (presumably because of copying), then its directory date is reset to match the internal date. FILES can be a list of file names or a pattern interpretable by FILDIR. Returns a list of files whose dates have been changed. (FIX-EQUIV-DATES CDENTRIES) [Function] If there is an entry in CDENTRIES whose files are EQUIVALENT but with different directory creation dates, the directory date of the file with the later date (presumably a copy) is reset to match the date of the earlier file. In the end all equivalent files will have the same (earliest) date. Returns a list of files whose dates have been changed. (COPY-MISSING-FILES CDENTRIES TARGET MATCHNAMES) [Function] Target is 1 or 2, indicating the direction of potential copies. If an entry with a source file but no target file has a matchname in MATCHNAMES, the source file is copied to the target directory. All target-absent files are copied if MATCNAMES is NIL. Source properties (including version number) are preserved in the target. (COPY-COMPARED-FILES CDENTRIES TARGET MATCHNAMES) [Function] Target is 1 or 2, indicating the direction of potential copies. If an entry with both source and target files has a matchname in MATCHNAMES, the source file is copied to a new version of the target file. All files are copied if MATCHNAMES is NIL. (COMPARE-ENTRY-SOURCE-FILES CDENTRY LISTSTREAM EXAMINE DW?) [Function] This is a simple wrapper for calling COMPARESOURCES if the CDENTRY files are Lisp source files. The function (CDENTRY MATCHNAME CDENTRIES is useful for extracting a particular entry, with CDENTRIES defaulting to LASTCDENTRIES. (COMPILED-ON-SAME-SOURCE CDENTRIES) [Function] Returns the subset of entries with Lisp compiled files (dfasl or lcom) that are compiled on the same source, according to SOURCE-FOR-COMPILED-P below. Presumably one should be removed to avoid confusion. (FIND-SOURCE-FILES CFILES SDIRS DFASLMARGIN) [Function] Returns (CFILE . SFILES) pairs where CFILE is a Lisp compiled file in CFILES and SFILES is list of files in SDIRS that CFILE was compiled on according to SOURCE-FOR-COMPILED-P. This suggests that at least one of SFILES should be copied to CFILE's location (or vice versa). (FIND-COMPILED-FILES SFILES CDIRS DFASLMARGIN) [Function] Returns (SFILE . CFILES) pairs where SFILE is a Lisp source file in SFILES and CFILES are files in CDIRS that are compiled on SFILE according to SOURCE-FOR-COMPILED-P. This suggests that at least one of CFILES should be copied to SFILE's location. (FIND-UNCOMPILED-FILES FILES DFASLMARGIN COMPILEXTS) [Function] Returns a list of elements each of which corresponds to a source file in FILES for which no appropriate compiled file can be found. An appropriate compiled file is a file in the same location with extension in COMPILEEXTS (defaulting to *COMPILED-EXTENSIONS*) that satisfies SOURCE-FOR-COMPILED-P. Each element is a list of the form (sourcefile . cfiles) cfiles contains compiled files that were compiled on a different version of sourcefile, NIL if no such files exist. Each cfile item is a pair (cfile timediff) where timediff is the time difference (in minutes) between the creation date of the compiled-file's source and the creation date of sourcefile (positive if the cfile was compiled later, as should be the case). FILES can be an explicit list of files, or a file specification interpretable by FILDIR; in that case only the newest source-file versions are processed. (FIND-UNSOURCED-FILES CFILES DFASLMARGIN COMPILEXTS) [Function] Returns the subset of the compiled files specified by CFILES for which a corresponding source file according to SOURCE-FOR-COMPILED-P cannot be found in the same directory. CFILES can be a list of files or a pattern that FILDIR can interpret. COMPILEEXTS can be one or more explicit compile-file extensions, defaulting to *COMPILED-EXTENSIONS*. (SOURCE-FOR-COMPILED-P SOURCE COMPILED DFASLMARGIN) [Function] Returns T if it can confirm that Lisp COMPILED file was compiled on Lisp SOURCE file. SOURCE and COMPILED can be provided as CREATED-AS values, to avoid repetitive computation. This compares the information in the filecreated expressions, original file names and original dates, and not the current directory names and dates. It appears that the times in DFASL files may differ from the filecreated source dates by a few minutes. The DFASLMARGIN can be provided to loosen up the date matching criterion. DFASLMARGIN is a pair (max min) and a DFASL COMPILED is deemed to be compiled on SOURCE if the compiled's source date is no more than max and no less than min minutes after the source date. A negative min allows for the possibility that the compiled-source date is earlier than the candidate source date. DFASLMARGIN defaults to (20 0). A single positive number x is coerced to (x 0). A single negative number is coerced to (-x x) (compiled file is no more than x minutes later or earlier). T is infinity in either direction. Examples: (T 0): COMPILED compiled on source later than SOURCE (0 T): COMPILED compiled on source earlier than SOURCE (odd) 12: COMPILED compiled on source later than SOURCE by no more than 12 minutes -12: COMPILED compiled on source 12 minutes before or after SOURCE (FIND-MULTICOMPILED-FILES FILES SHOWINFO) [Function] Returns a list of files in FILES that have more than one type of compiled file (e.g. LCOM and DFASL). FILES is interpretable by FILDIR. If SHOWINFO, then the value contains a list for each file of the form ÿÿï!ÿ(rootname loaded-version . CREATED-AS information for each compile-type) Otherwise just the rootname of the source is returns. (CREATED-AS FILE) [Function] If FILE is a Lisp source or compiled file, returns a record of its original filename and filecreated dates, and for compiled files, also the original compiled-on name and date. The return for a source file is a pair (sfullname sfilecreateddate) The return for a compiled file is a quadruple (cfullname cfilecreated sfullname sfilecreateddate) where sfullname and sourcefilecreated are extracted from the file's compiled-on information. The return is (fullname NIL) for a non-Lisp file. (EOLTYPE FILE SHOWCONTEXT) [Function] Returns the EOLTYPE of FILE (CR, LF, CRLF) if the type is unmistakable: contains at least one instance of one type and no instances of any others. Returns NIL if there is evidence of inconsistent types. If SHOWCONTEXT is an integer, it is the number of bytes for EOLTYPE to display before and after an instance of an inconsistent type. At each instance, the user is asked whether to continue scanning for other instances. SHOWCONTEXT = T is interpreted as 100. (BINCOMP FILE1 FILE2 EOLDIFFOK) [Function] Returns T if FILE1 and FILE2 are byte-identical. If EOLDIFFOK and FILE1 and FILE2 differ only in their eol conventions, the value is a list of the form (EOL1 EOL2), e.g. (CR CRLF). Otherwise the value is NIL. (LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC) STARTINGPAGE# 1) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))))) 4ÈÈ40ÈÈ4 ÈÈ4ÈÈ.4@È4ÈÈ.È.ŠŠ8.ŠŠ8JÈÈ PAGEHEADING RUNNINGHEAD. GACHA TERMINALMODERN MODERN @@ -14,5 +14,5 @@ XEROX COMPAREDIRECTORIES 2 4 1 COMPAREDIRECTORIES 1 4 By: Larry Masinter a  HRULE.GETFNMODERN #!(ž  \ -fJLL44C›Š€£6)˜.©Ú‹”K¦ÙN7ÉX1_A P]Ž»'%Z.“,]>I?û= ä0Ì:<ûAOA[@HÑ:BRJ6ÐK7Ù".9“-Õ  - 0 zº \ No newline at end of file +fJLL44C›Š€£6)˜.©Ú‹”K¦ÙN7ÉX1_A P]Ž»'%Z.“,]>I?û= ä0Ì:<ûAOA[@HÑ:BRJ6ÐK7Ù".9'Ñ-Õ  + 1Wzº \ No newline at end of file diff --git a/lispusers/COMPAREDIRECTORIES.TEDIT.~110~ b/lispusers/COMPAREDIRECTORIES.TEDIT.~110~ deleted file mode 100644 index d3559442..00000000 --- a/lispusers/COMPAREDIRECTORIES.TEDIT.~110~ +++ /dev/null @@ -1,18 +0,0 @@ -XEROX COMPAREDIRECTORIES 2 4 1 COMPAREDIRECTORIES 1 4 By: Larry Masinter and Ron Kaplan This document edited on December 2, 1987 December 28, 1998 (Ron Kaplan) April 7, 2018 (Ron Kaplan) Rewritten August 25, 2020 (Ron Kaplan) COMPAREDIRECTORIES compares the contents of two directories, identifying files according to their creation dates and lengths. It is called using the function (COMPAREDIRECTORIES DIR1 DIR2 SELECT FILEPATTERNS EXTENSIONSTOAVOID USEDIRECTORYDATES OUTPUTFILE ALLVERSIONS) [Function] Compares the creation dates of files with matching names in the lists that CDFILES returns for DIR1 and DIR2. Collects or prints CDENTRIES for those files that meet the SELECT criteria. May also collect or print entries for relevant files that exist in DIR1 or DIR2 but not both. SELECT specifies which the match/mismatch criteria for filtering the output. If SELECT is or contains AFTER or >: select entries where file1 has a later date than file2 BEFORE or <: select entries where file1 has an earlier date than file2 SAMEDATE or =: select entries where file1 and file2 have the same date -*: exclude entries where file1 does not exist *-: exclude entries where file2 does not exist SELECT = NIL is equivalent to (< > -* *-). Excludes files with matching dates, a useful default for identifying files that may require further attention. SELECT = T is equivalent to (= < > -* *-). Includes all files for processing by other functions or later filtering by CDSUBSET (below). SELECT may also contain the token AUTHOR to indicate that authors should be provided in the printed output (see CDPRINT below). Unless USEDIRECTORYDATES, the FILECREATED date is used for the date comparison of Lisp source and compiled files, otherwise the file-system CREATIONDATE is used. If OUTPUTFILE=NIL, then a list of the form (Parameters . entries) is returned. Parameters is a list (DIR1 DIR2 SELECT DATE) that records the parameters of the comparison. Entries contains one entry for each of the file-comparisons that meets the SELECT criteria. Each entry is a CDENTRY record with fields (matchname info1 daterel info2 equiv) where matchname is the name.extension shared by the two files, and each file info is either NIL (for nonexistent files) or a CDINFO record with fields (fullfilename date length author type eol) type is SOURCE for Lisp source (filecreated) files, COMPILED for Lisp compiled files, otherwise the PRINTFILETYPE (TEXT, TEDIT...) or NIL. eol is CR, LF, CRLF, or NIL. When both files exist, the date relation is one of <, =, or >. Otherwise, the date relation is * if only one file exists. EQUIV is EQUIVALENT for files with different dates but exactly the same bytes, otherwise NIL. If OUTPUTFILE is not NIL, then it is a filename or open stream on which selected entries will be printed (T for the terminal) by CDPRINT. COMPAREDIRECTORIES sets the variable LASTCDENTRIES is set to the selected entries. This is used by the functions below if their CDENTRIES is NIL. (CDFILES DIR FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH) [Function] Returns a list of full filenames for files in directory DIR (NIL=T=the connected directory) that match the other file-name filtering criteria. Files are excluded if: Their name does not match a pattern in FILEPATTERNS (NIL = *). Dotted files are excluded unless FILEPATTERNS includes .* and files in subdirectories are excluded if the number of subdirectories exceeds DEPTH (below). Their extension is in the list EXTENSIONSTOAVOID (* excludes all extensions). They are not the highest version unless ALLVERSIONS=T. DEPTH controls the depth of subdirectory exploration. T means all levels, NIL means no subdirectories. Otherwise the maximum number of ">" characters below the starting DIR in the fullname of files. (CDFILES) produces all the newest, undotted files in the immediate connected directory. (CDPRINT CDENTRIES FILE PRINTAUTHOR) [Function] Prints CDENTRIES on FILE, with one line for each entry. The line for each entry is of the form FILE1 (AUTHOR) SIZE DATE relation DATE FILE2 (AUTHOR) SIZE For example ACE.;1 (Joe) 4035 2-May-1985 18:03:54 < 30-Sep-1985 11:14:48 ACE.;3 (Sam) 5096. The line for byte-equivalent files is prefixed with ==. If the files are equivalent except for a difference in end-of-line conventions, the equivalence prefix will indicate the convention for each file (C for CR, L, for LF, 2 for CRLF). Thus C2 indicates that the files are equivalent except that file1 marks line ends with CR and file2 with CRLF. Note that because of the setting of LASTCDENTRIES, evaluating (CDPRINT) after COMPAREDIRECTORIES prints the results of the last comparision. For conciseness, authors are included only if PRINTAUTHOR or if AUTHOR is included in the SELECT parameter of CDENTRIES. Also, the redundant file-name hosts/directories are not printed. (CDMAP CDENTRIES FN) [Function] (CDSUBSET CDENTRIES FN) [Function] CDMAP applies FN to each CDENTRY in CDENTRIES. CDSUBSET applies FN and also returns the subset of CDENTRIES for which FN is non-NIL and preserves in the value the parameters of CDENTRIES. For convenience, at each invocation the variables MATCHNAME INFO1 DATEREL INFO2 and EQUIV are bound to the corresponding fields and can be used freely by FN. USEFUL UTILITIES (FIX-DIRECTORY-DATES FILES) [Function] For every file included in or specified by FILES, if it is a Lisp source or compiled whose directory creation date is more than 30 seconds later than its internal filecreated date (presumably because of copying), then its directory date is reset to match the internal date. FILES can be a list of file names or a pattern interpretable by FILDIR. Returns a list of files whose dates have been changed. (FIX-EQUIV-DATES CDENTRIES) [Function] If there is an entry in CDENTRIES whose files are EQUIVALENT but with different directory creation dates, the directory date of the file with the later date (presumably a copy) is reset to match the date of the earlier file. In the end all equivalent files will have the same (earliest) date. Returns a list of files whose dates have been changed. (COPY-MISSING-FILES CDENTRIES TARGET MATCHNAMES) [Function] Target is 1 or 2, indicating the direction of potential copies. If an entry with a source file but no target file has a matchname in MATCHNAMES, the source file is copied to the target directory. All target-absent files are copied if MATCNAMES is NIL. Source properties (including version number) are preserved in the target. (COPY-COMPARED-FILES CDENTRIES TARGET MATCHNAMES) [Function] Target is 1 or 2, indicating the direction of potential copies. If an entry with both source and target files has a matchname in MATCHNAMES, the source file is copied to a new version of the target file. All files are copied if MATCHNAMES is NIL. (COMPARE-ENTRY-SOURCE-FILES CDENTRY LISTSTREAM EXAMINE DW?) [Function] This is a simple wrapper for calling COMPARESOURCES if the CDENTRY files are Lisp source files. The function (CDENTRY MATCHNAME CDENTRIES is useful for extracting a particular entry, with CDENTRIES defaulting to LASTCDENTRIES. (COMPILED-ON-SAME-SOURCE CDENTRIES) [Function] Returns the subset of entries with Lisp compiled files (dfasl or lcom) that are compiled on the same source, according to SOURCE-FOR-COMPILED-P below. Presumably one should be removed to avoid confusion. (FIND-SOURCE-FILES CFILES SDIRS DFASLMARGIN) [Function] Returns (CFILE . SFILES) pairs where CFILE is a Lisp compiled file in CFILES and SFILES is list of files in SDIRS that CFILE was compiled on according to SOURCE-FOR-COMPILED-P. This suggests that at least one of SFILES should be copied to CFILE's location (or vice versa). (FIND-COMPILED-FILES SFILES CDIRS DFASLMARGIN) [Function] Returns (SFILE . CFILES) pairs where SFILE is a Lisp source file in SFILES and CFILES are files in CDIRS that are compiled on SFILE according to SOURCE-FOR-COMPILED-P. This suggests that at least one of CFILES should be copied to SFILE's location. (FIND-UNCOMPILED-FILES FILES DFASLMARGIN COMPILEXTS) [Function] Returns a list of elements each of which corresponds to a source file in FILES for which no appropriate compiled file can be found. An appropriate compiled file is a file in the same location with extension in COMPILEEXTS (defaulting to *COMPILED-EXTENSIONS*) that satisfies SOURCE-FOR-COMPILED-P. Each element is a list of the form (sourcefile . cfiles) cfiles contains compiled files that were compiled on a different version of sourcefile, NIL if no such files exist. Each cfile item is a pair (cfile timediff) where timediff is the time difference (in minutes) between the creation date of the compiled-file's source and the creation date of sourcefile (positive if the cfile was compiled later, as should be the case). FILES can be an explicit list of files, or a file specification interpretable by FILDIR; in that case only the newest source-file versions are processed. (FIND-UNSOURCED-FILES CFILES DFASLMARGIN COMPILEXTS) [Function] Returns the subset of the compiled files specified by CFILES for which a corresponding source file according to SOURCE-FOR-COMPILED-P cannot be found in the same directory. CFILES can be a list of files or a pattern that FILDIR can interpret. COMPILEEXTS can be one or more explicit compile-file extensions, defaulting to *COMPILED-EXTENSIONS*. (SOURCE-FOR-COMPILED-P SOURCE COMPILED DFASLMARGIN) [Function] Returns T if it can confirm that Lisp COMPILED file was compiled on Lisp SOURCE file. SOURCE and COMPILED can be provided as CREATED-AS values, to avoid repetitive computation. This compares the information in the filecreated expressions, original file names and original dates, and not the current directory names and dates. It appears that the times in DFASL files may differ from the filecreated source dates by a few minutes. The DFASLMARGIN can be provided to loosen up the date matching criterion. DFASLMARGIN is a pair (max min) and a DFASL COMPILED is deemed to be compiled on SOURCE if the compiled's source date is no more than max and no less than min minutes after the source date. A negative min allows for the possibility that the compiled-source date is earlier than the candidate source date. DFASLMARGIN defaults to (20 0). A single positive number x is coerced to (x 0). A single negative number is coerced to (-x x) (compiled file is no more than x minutes later or earlier). T is infinity in either direction. Examples: (T 0): COMPILED compiled on source later than SOURCE (0 T): COMPILED compiled on source earlier than SOURCE (odd) 12: COMPILED compiled on source later than SOURCE by no more than 12 minutes -12: COMPILED compiled on source 12 minutes before or after SOURCE (FIND-MULTICOMPILED-FILES FILES SHOWINFO) [Function] Returns a list of files in FILES that have more than one type of compiled file (e.g. LCOM and DFASL). FILES is interpretable by FILDIR. If SHOWINFO, then the value contains a list for each file of the form ÿÿï!ÿ(rootname loaded-version . CREATED-AS information for each compile-type) Otherwise just the rootname of the source is returns. (CREATED-AS FILE) [Function] If FILE is a Lisp source or compiled file, returns a record of its original filename and filecreated dates, and for compiled files, also the original compiled-on name and date. The return for a source file is a pair (sfullname sfilecreateddate) The return for a compiled file is a quadruple (cfullname cfilecreated sfullname sfilecreateddate) where sfullname and sourcefilecreated are extracted from the file's compiled-on information. The return is (fullname NIL) for a non-Lisp file. (EOLTYPE FILE) [Function] Returns the EOLTYPE of FILE (CR, LF, CRLF) if the type is unmistakable: contains at least one instance of one type and no instances of any others. (BINCOMP FILE1 FILE2 EOLDIFFOK) [Function] Returns T if FILE1 and FILE2 are byte-identical. If EOLDIFFOK and FILE1 and FILE2 differ only in their eol conventions, the value is a list of the form (EOL1 EOL2), e.g. (CR CRLF). Otherwise the value is NIL. (LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC) STARTINGPAGE# 1) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))))) 4ÈÈ40ÈÈ4 ÈÈ4ÈÈ.4@È4ÈÈ.È.ŠŠ8.ŠŠ8JÈÈ PAGEHEADING RUNNINGHEAD. -GACHA -TERMINALMODERN -MODERN -TERMINAL -MODERN MODERN -MODERNLOGOMODERN -    HRULE.GETFNMODERN - - HRULE.GETFNMODERN - - HRULE.GETFNMODERN -   HRULE.GETFNMODERN  - HRULE.GETFNMODERN #!(ž - -\ -fJLL44›Š€£6)˜.©Ú‹”K¦ÙN7ÉX1_A P]Ž»'%Z.“,]>I?û= ä0Ì:<ûAOA[@HÑ:BRJ6ÐK7Ù".9“-Õ  - /Êzº \ No newline at end of file diff --git a/lispusers/COMPAREDIRECTORIES.TEDIT.~8~ b/lispusers/COMPAREDIRECTORIES.TEDIT.~8~ deleted file mode 100644 index ca45d6e2..00000000 Binary files a/lispusers/COMPAREDIRECTORIES.TEDIT.~8~ and /dev/null differ diff --git a/lispusers/COMPAREDIRECTORIES.~261~ b/lispusers/COMPAREDIRECTORIES.~261~ deleted file mode 100644 index f50e0dad..00000000 --- a/lispusers/COMPAREDIRECTORIES.~261~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "12-Oct-2020 23:48:57"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;261 60872 changes to%: (FNS COMPAREDIRECTORIES CDFILES COMPAREDIRECTORIES.INFOS CDPRINT.LINE CDPRINT) previous date%: "12-Oct-2020 20:22:51" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;254) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990, 1994, 1998, 2018, 2020 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COMPAREDIRECTORIESCOMS) (RPAQQ COMPAREDIRECTORIESCOMS ( (* ;; "Compare the contents of two directories.") (FNS COMPAREDIRECTORIES CDFILES COMPAREDIRECTORIES.INFOS MATCHNAME) (FNS CDPRINT CDPRINT.LINE) (FNS CDMAP CDENTRY CDSUBSET) (FNS BINCOMP EOLTYPE) (RECORDS CDENTRY CDINFO) (* ;; "look for compiled files older than the sources") (FNS FIND-UNCOMPILED-FILES FIND-UNSOURCED-FILES FIND-SOURCE-FILES FIND-COMPILED-FILES FIND-UNLOADED-FILES FIND-LOADED-FILES FIND-MULTICOMPILED-FILES) (FNS CREATED-AS SOURCE-FOR-COMPILED-P COMPILE-SOURCE-DATE-DIFF) (FNS FIX-DIRECTORY-DATES FIX-EQUIV-DATES COPY-COMPARED-FILES COPY-MISSING-FILES COMPILED-ON-SAME-SOURCE) [VARS (ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"] (INITVARS (LASTCDENTRIES NIL)) (COMS (FNS COMPARE-ENTRY-SOURCE-FILES) (FILES COMPARESOURCES)))) (* ;; "Compare the contents of two directories.") (DEFINEQ (COMPAREDIRECTORIES [LAMBDA (DIR1 DIR2 SELECT FILEPATTERNS EXTENSIONSTOAVOID USEDIRECTORYDATE OUTPUTFILE ALLVERSIONS) (* ; "Edited 12-Oct-2020 23:48 by rmk:") (* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on DIR1 and DIR2, listing which is newer, or when one is not found on the other. If SELECT is or contains SAME/=, BEFORE/<, AFTER/>, then files where DIR1 is the same as, earlier than, or later than DIR2 are selected. SELECT= NIL is the same as (< >), T is the same as (< > =). Also allows selection based on file-length criteria.") (* ;; "") (* ;; "Unless USEDIRECTORYDATE, comparison is with respect to the the LISP filecreated dates if evailable.") (* ;; "") (* ;; "If OUTPUTFILE is NIL, the list of compared entries is returned. Otherwise the selected entries are printed on OUTPUTFILE (T for the display).") [SETQ SELECT (SELECTQ SELECT (NIL '(< > -* *-)) (T '(< > -* *- =)) (FOR S IN (MKLIST SELECT) COLLECT (SELECTQ S ((AFTER >) '>) ((BEFORE <) '<) ((SAME SAMEDATE =) '=) (AUTHOR 'AUTHOR) (-* '-*) (*- '*-) (ERROR "UNRECOGNIZED SELECT PARAMETER" S] (PROG (INFOS1 INFOS2 CANDIDATES SELECTED COMPAREDATE) [SETQ COMPAREDATE (INTERSECTION SELECT '(< > =] (* ;; "DIRECTORYNAME here to get unrelativized specifications for header.") (SETQ DIR1 (OR (DIRECTORYNAME (OR DIR1 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR1))) (SETQ DIR2 (OR (DIRECTORYNAME (OR DIR2 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR2))) (PRINTOUT T "Comparing " DIR1 6 "vs. " DIR2 T "as of " (DATE) " selecting " SELECT " ... ") (SETQ INFOS1 (COMPAREDIRECTORIES.INFOS (CDFILES DIR1 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS) USEDIRECTORYDATE)) (SETQ INFOS2 (COMPAREDIRECTORIES.INFOS (CDFILES DIR2 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS) USEDIRECTORYDATE)) (CL:UNLESS (AND INFOS2 INFOS1) (RETURN)) (* ;; "At this point the CAR of each info is the atomic match-name. Peel it off to produce candidate entries.") (* ;;  "Look through all of the I2's because multiple versions (if VERSIONS) have the same matchname") [SETQ CANDIDATES (FOR I1 IN INFOS1 JOIN (IF ALLVERSIONS THEN (OR (FOR I2 IN INFOS2 WHEN (EQ (CAR I2) (CAR I1)) COLLECT (LIST (CAR I1) (CDR I1) (CDR I2))) (CONS (LIST (CAR I1) (CDR I1) NIL))) ELSE (CONS (LIST (CAR I1) (CDR I1) (CDR (ASSOC (CAR I1) INFOS2] (* ;; "Could be some 2's without 1's") (SORT [NCONC CANDIDATES (FOR I2 IN INFOS2 UNLESS (ASSOC (CAR I2) CANDIDATES) COLLECT (LIST (CAR I2) NIL (CDR I2] T) (* ;; "CANDIDATES is now a sorted list of the form (matchname entry1 entry2) where an entry consists of (fullname date length author)") (* ;; "Do the SELECT filtering and insert the date relation.") [SETQ SELECTED (FOR C MATCHNAME INFO1 INFO2 IDATE1 IDATE2 DATEREL BINCOMP IN CANDIDATES EACHTIME (SETQ MATCHNAME (POP C)) (SETQ INFO1 (POP C)) (SETQ INFO2 (POP C)) (IF (AND INFO1 INFO2) THEN (SETQ IDATE1 (IDATE (FETCH DATE OF INFO1))) (SETQ IDATE2 (IDATE (FETCH DATE OF INFO2))) (SETQ DATEREL (IF (IGREATERP IDATE1 IDATE2) THEN '> ELSEIF (ILESSP IDATE1 IDATE2) THEN '< ELSE '=)) ELSE (* ;; "Just for printing--no comparison") (SETQ DATEREL '*)) WHEN (IF (AND INFO1 INFO2) THEN (OR (NULL COMPAREDATE) (SELECTQ DATEREL (> (MEMB '> SELECT)) (< (MEMB '< SELECT)) (= (MEMB '= SELECT)) (SHOULDNT))) ELSEIF INFO1 THEN (* ;; "OK if INFO2 is missing?") (MEMB '*- SELECT) ELSE (* ;; "OK if INFO1 is missing?") (MEMB '-* SELECT)) COLLECT (CREATE CDENTRY MATCHNAME _ MATCHNAME INFO1 _ INFO1 DATEREL _ DATEREL INFO2 _ INFO2 EQUIV _ (CL:UNLESS (EQ DATEREL '*) (BINCOMP (FETCH FULLNAME OF INFO1) (FETCH FULLNAME OF INFO2) T))] (PRINTOUT T (LENGTH SELECTED) " entries" T) (PUSH SELECTED (LIST DIR1 DIR2 SELECT (DATE))) (SETQ LASTCDENTRIES SELECTED) (CL:UNLESS OUTPUTFILE (RETURN SELECTED)) (RETURN (CDPRINT SELECTED OUTPUTFILE (MEMB 'AUTHOR SELECT SELECT]) (CDFILES [LAMBDA (DIR FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH) (* ; "Edited 12-Oct-2020 23:48 by rmk:") (* ;; "Returns a list of fullnames for files that satisfy the criteria") (* ;; "For each name returned by (DIRECTORY DIR), assumes that FILEPATTERNS applies to the suffix after the directory (i.e. after NAMEPOS). That includes possibly subdirectories, dotted files in ultimate file names, and versions.") (* ;; " Exclude subdirectories unless FILEPATTERNS includes *>*") (* ;; " Exclude dotted files (.xxx) unless FILEPATTERNS includes .*") (* ;; " Exclude files with extensions in EXTENSIONSTOAVOID (*=NIL does no filtering)") (* ;; " Exclude older versions unless ALLVERSIONS=T") (* ;; " DEPTH is the number of subdirectories below the ones specified in DIR (NIL top-level of DIR only, T = any depth)") (* ;; "Resolve relative directories, so we can suppress subdirectory matches. ") (SETQ EXTENSIONSTOAVOID (MKLIST (U-CASE EXTENSIONSTOAVOID))) [SETQ FILEPATTERNS (MKLIST (OR FILEPATTERNS '*] (FOR FP FN FPNAME FPEXT (TOPDIR _ (DIRECTORYNAME (OR DIR T))) IN FILEPATTERNS JOIN [SETQ FPNAME (U-CASE (OR (FILENAMEFIELD FP 'NAME) '*] [SETQ FPEXT (U-CASE (OR (FILENAMEFIELD FP 'EXTENSION) '*] (SETQ FN (PACKFILENAME.STRING 'VERSION (CL:IF ALLVERSIONS '* "") 'DIRECTORY TOPDIR 'NAME '* 'EXTENSION '*)) (* ;; "DEPTH is the number of internal %">%"") [IF (OR (EQ DEPTH T) (EQ FP '*)) THEN (SETQ DEPTH MAX.SMALLP) ELSEIF DEPTH ELSE (SETQ DEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FN 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT] (FOR FULLNAME NAME EXT THISDEPTH IN (DIRECTORY FN) EACHTIME [SETQ NAME (U-CASE (FILENAMEFIELD FULLNAME 'NAME] [SETQ EXT (U-CASE (FILENAMEFIELD FULLNAME 'EXTENSION] (SETQ THISDEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FULLNAME 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT))) (* ;; "An empty subdirectory may appear without name or extensions") WHEN (AND (OR NAME EXT) (OR (EQ FPNAME '*) (EQ FPNAME NAME)) (OR (EQ FPEXT '*) (EQ FPEXT EXT))) UNLESS [OR (IGREATERP THISDEPTH DEPTH) (AND EXT (OR (MEMB '* EXTENSIONSTOAVOID) (MEMB EXT EXTENSIONSTOAVOID] COLLECT FULLNAME) FINALLY (CL:UNLESS $$VAL (PRINTOUT T "No relevant files in " TOPDIR T]) (COMPAREDIRECTORIES.INFOS [LAMBDA (FILES USEDIRECTORYDATE) (* ; "Edited 12-Oct-2020 21:56 by rmk:") (* ;; "Value is a list of CDINFOS with the match-name consed on to the front") (FOR FULLNAME TYPE LDATE IN FILES COLLECT (* ;; "GDATE/IDATE in case Y2K") (SETQ LDATE (FILEDATE FULLNAME)) (* ; "Is it a Lisp file?") (CONS (MATCHNAME FULLNAME) (CREATE CDINFO FULLNAME _ FULLNAME DATE _ [GDATE (IDATE (IF USEDIRECTORYDATE THEN (GETFILEINFO FULLNAME 'CREATIONDATE) ELSEIF (OR LDATE (GETFILEINFO FULLNAME 'CREATIONDATE] LENGTH _ (GETFILEINFO FULLNAME 'LENGTH) AUTHOR _ (GETFILEINFO FULLNAME 'AUTHOR) TYPE _ (IF LDATE THEN (CL:IF (MEMB (FILENAMEFIELD FULLNAME 'EXTENSION) *COMPILED-EXTENSIONS*) 'COMPILED 'SOURCE) ELSE (PRINTFILETYPE FULLNAME]) (MATCHNAME [LAMBDA (NAME) (* ; "Edited 5-Sep-2020 13:41 by rmk:") (* ;; "The NAME.DIR for matching related files") (LET ((M (PACKFILENAME 'HOST NIL 'VERSION NIL 'DIRECTORY NIL 'BODY NAME))) (* ;; "Strip off the nuisance period") (CL:IF (EQ (CHARCODE %.) (NTHCHARCODE M -1)) (SUBATOM M 1 -2) M)]) ) (DEFINEQ (CDPRINT [LAMBDA (CDENTRIES FILE PRINTAUTHOR) (* ; "Edited 12-Oct-2020 21:47 by rmk:") (* ;; "Typically CDENTRIES will have a header. If not, we fake one up, at least for the directories and today's date.") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (RESETLST (LET (INFO1 TEXT STREAM DATE1POS ENDDATE1 DIR1 DIR2 (HEADER (CAR CDENTRIES))) (CL:UNLESS (STRINGP (CADR HEADER)) (SETQ HEADER (LIST [FOR E IN CDENTRIES WHEN (FETCH INFO1 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO1 OF E] [FOR E IN CDENTRIES WHEN (FETCH INFO2 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO2 OF E] NIL (DATE))) (PUSH CDENTRIES HEADER)) (SETQ DIR1 (CAR HEADER)) (SETQ DIR2 (CADR HEADER)) (CL:UNLESS (SETQ STREAM (GETSTREAM FILE 'OUTPUT T)) [RESETSAVE (SETQ STREAM (OPENSTREAM (PACKFILENAME 'EXTENSION 'TXT 'BODY FILE) 'OUTPUT 'NEW)) '(PROGN (CLOSEF? OLDVALUE]) (CL:WHEN DIR1 (PRINTOUT STREAM "Comparing " DIR1 6 "vs. " DIR2 T "as of " (CADDDR HEADER)) (CL:WHEN (CADDR HEADER) (PRINTOUT STREAM " selecting " (CADDR HEADER))) (PRINTOUT STREAM -2 (LENGTH (CDR CDENTRIES)) " entries" T T)) (LINELENGTH 1000 STREAM) (* ; "Don't wrap") (* ;; "DATE1POS is the position of the first character of INFO1's date, used for tabbing. We have to measure the filename, date, size, and author if desired") (IF (CDR CDENTRIES) THEN (FOR E INFO1 (MAXDATE1WIDTH _ 0) (SPACEWIDTH _ 1) (PARENWIDTH _ 2) IN (CDR CDENTRIES) WHEN (SETQ INFO1 (FETCH INFO1 OF E)) LARGEST [SETQ MAXDATE1WIDTH (IMAX MAXDATE1WIDTH (NCHARS (FETCH DATE OF INFO1] (IPLUS (NCHARS (PACKFILENAME 'HOST NIL 'DIRECTORY NIL 'BODY (FETCH FULLNAME OF INFO1))) (NCHARS (FETCH LENGTH OF INFO1)) (CL:IF PRINTAUTHOR (IPLUS SPACEWIDTH PARENWIDTH (NCHARS (FETCH AUTHOR OF INFO1))) 0)) FINALLY (* ;;  "First 4 for width of equiv. $$EXTREME is NIL if there are no INFO1's") (SETQ DATE1POS (IPLUS (OR $$EXTREME 10) 4 (ITIMES 3 SPACEWIDTH))) (SETQ ENDDATE1 (IPLUS DATE1POS MAXDATE1WIDTH) )) (FOR E IN (CDR CDENTRIES) DO (CDPRINT.LINE STREAM E PRINTAUTHOR DATE1POS ENDDATE1) ) ELSE (PRINTOUT T "CDENTRIES is empty" T)) (AND STREAM (CLOSEF? STREAM))))]) (CDPRINT.LINE [LAMBDA (STREAM ENTRY PRINTAUTHOR DATE1POS ENDDATE1) (* ; "Edited 12-Oct-2020 21:47 by rmk:") (* ;; "Format one line of the directory comparison listing. If PRINTAUTHOR and AUTHOR1 or AUTHOR2 are non-NIL, list the author in parens; otherwise omit it.") (LET ((INFO1 (FETCH INFO1 OF ENTRY)) (INFO2 (FETCH INFO2 OF ENTRY)) EQUIV) (SETQ EQUIV (FETCH EQUIV OF ENTRY)) (PRINTOUT STREAM (SELECTQ EQUIV (T "==") (NIL " ") (IF (EQUAL EQUIV '(CR LF)) THEN "CL" ELSEIF (EQUAL EQUIV '(LF CR)) THEN "LC" ELSEIF (EQ 'CRLF (CAR EQUIV)) THEN (CONCAT "2" (CL:IF (EQ 'CR (CADR EQUIV)) 'L 'C)) ELSE (* ;; "CADR must be CRLF") (CONCAT (CL:IF (EQ 'CR (CAR EQUIV)) 'L 'C) "2"))) " ") (CL:WHEN INFO1 (PRINTOUT STREAM (PACKFILENAME 'HOST NIL 'DIRECTORY NIL 'BODY (FETCH FULLNAME OF INFO1)) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO1) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO1) .TAB0 DATE1POS (FETCH DATE OF INFO1))) (PRINTOUT STREAM .TAB0 ENDDATE1 " " (FETCH DATEREL OF ENTRY) " ") (CL:WHEN INFO2 (PRINTOUT STREAM (FETCH DATE OF INFO2) " " (PACKFILENAME 'HOST NIL 'DIRECTORY NIL 'BODY (FETCH FULLNAME OF INFO2)) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO2) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO2))) (TERPRI STREAM]) ) (DEFINEQ (CDMAP [LAMBDA (CDENTRIES FN) (* ; "Edited 6-Sep-2020 15:58 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) DO (APPLY* FN CDE]) (CDENTRY [LAMBDA (MATCHNAME CDENTRIES) (* ; "Edited 5-Sep-2020 21:09 by rmk:") (ASSOC MATCHNAME (OR CDENTRIES LASTCDENTRIES]) (CDSUBSET [LAMBDA (CDENTRIES FN) (* ; "Edited 15-Sep-2020 13:49 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (CONS (CAR CDENTRIES) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) WHEN (APPLY* FN CDE) COLLECT CDE]) ) (DEFINEQ (BINCOMP [LAMBDA (FILE1 FILE2 EOLDIFFOK) (* ; "Edited 12-Oct-2020 17:14 by rmk:") (* ;; "Returns T if FILE1 and FILE2 are byte-equivalent. Returns EOLDIFF if they are byte equivalent except for CR/LF/CRLF exchanges. ") (IF (IEQP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) THEN [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND B1 B2 EOL1 EOL2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS (AND EOLDIFFOK (SELCHARQ B1 (CR (CL:WHEN (EQ EOL1 'LF) (RETURN NIL)) (SETQ EOL1 'CR) (SETQ EOL2 'LF) (EQ B2 (CHARCODE LF))) (LF (CL:WHEN (EQ EOL1 'CR) (RETURN NIL)) (SETQ EOL1 'LF) (SETQ EOL2 'CR) (EQ B2 (CHARCODE CR))) NIL)) (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T] ELSEIF EOLDIFFOK THEN (* ;; "Lengths are different possibly because of CRLF to CR/LF substitutions.") (* ;;  "More complex code could detect the EOLTYPE incrementally without separate passes, but ...") (LET ((EOL1 (EOLTYPE FILE1)) (EOL2 (EOLTYPE FILE2))) (CL:WHEN (IF [AND (EQ EOL1 'CRLF) (MEMB EOL2 '(LF CR] ELSEIF [AND (EQ EOL2 'CRLF) (MEMB EOL1 '(LF CR] THEN (SWAP FILE1 FILE2)) (* ;; "FILE1 is now CRLF, FILE2 is not. If FILE1 isn't longer, it can't have a CRLF that corresponds to a CR or LF.") (CL:WHEN (IGREATERP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND B1 B2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS [AND (EQ (CHARCODE CR) B1) (EQ (CHARCODE LF) (\BIN STREAM1)) (MEMB B2 (CHARCODE (CR LF] (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T]))]) (EOLTYPE [LAMBDA (FILE) (* ; "Edited 3-Sep-2020 17:05 by rmk:") (* ;; "Returns the EOLCONVENTION of FILE if it only sees one kind, NIL if it can't decide.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (SETFILEINFO STREAM 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND EOLTYPE DO (SELCHARQ (OR (\BIN STREAM) (RETURN EOLTYPE)) (CR (IF (EQ (CHARCODE LF) (\PEEKBIN STREAM T)) THEN (CL:WHEN (MEMB EOLTYPE '(LF CR)) (RETURN NIL)) (\BIN STREAM) (SETQ EOLTYPE 'CRLF) ELSEIF (MEMB EOLTYPE '(LF CRLF)) THEN (RETURN NIL) ELSE (SETQ EOLTYPE 'CR))) (LF (CL:WHEN (MEMB EOLTYPE '(CR CRLF)) (RETURN NIL)) (SETQ EOLTYPE 'LF)) NIL]) ) (DECLARE%: EVAL@COMPILE (RECORD CDENTRY (MATCHNAME INFO1 DATEREL INFO2 . EQUIV)) (RECORD CDINFO (FULLNAME DATE LENGTH AUTHOR TYPE)) ) (* ;; "look for compiled files older than the sources") (DEFINEQ (FIND-UNCOMPILED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 20-Sep-2020 23:04 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;; "Produces a list of the source files in FILES that have no corresponding compiled file") (* ;; "This determines whether there is at least one compiled file. If there are two or more, that's a problem") (* ;; "We want the most recent version only") (* ;; "Source files have a 2-element created-as with a non-NIL date") (SETQ FILES (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) UNLESS (MEMB (SETQ F (PACKFILENAME 'VERSION NIL 'BODY F)) $$VAL) COLLECT F)) (FOR F SCREATION FILES IN FILES WHEN (AND (CADR (SETQ SCREATION (CREATED-AS F))) (NOT (CDDR SCREATION))) WHEN [SETQ FILES (FOR CEXT CF IN (OR COMPILEEXTS *COMPILED-EXTENSIONS*) WHEN (SETQ CF (INFILEP (PACKFILENAME 'EXTENSION CEXT 'VERSION NIL 'BODY F))) COLLECT (CL:WHEN (SOURCE-FOR-COMPILED-P SCREATION CF DFASLMARGIN) (RETURN NIL)) CF FINALLY (* ;; "If we found some compiled files, they weren't on this source. If there weren't any compiled files to check, maybe there weren't any functions.") (* ;;  "NLSETQ because we don't want to stop if there is an error, typically from a package problem") (RETURN (OR $$VAL (LET [(FCOMS (CAR (NLSETQ (GETDEF (FILECOMS F) 'VARS F] (IF (NULL FCOMS) THEN (* ;;  "GETDEF caused an error. Maybe a package problem. ") (AND NIL 'NOCOMMANDS) ELSEIF (INFILECOMS? NIL '(FUNCTIONS FNS) FCOMS) THEN T] COLLECT (CONS F (SELECTQ FILES (T NIL) (NOCOMMANDS (CONS "No commands")) (FOR CF IN FILES COLLECT (* ;;  "Positive means that compiled is later than source, normal order but maybe by too much.") (* ;;  "Negative means that compiled came before source. Odd") (LIST CF (COMPILE-SOURCE-DATE-DIFF CF SCREATION]) (FIND-UNSOURCED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 15-Sep-2020 15:32 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;;  "Produces a list of compiled FILES for which no source file can be found in the same directory.") (* ;; "The source date in at least one DFASL was off by a second, maybe some sort of IDATE rounding? So, give a margin.") (* ;; "We want the most recent version only. Check CREATED-AS to make sure it really is a compiled file.") (* ;; "Sort to get lcoms and dfasls next to each other.") (LET (CCREATEDS) (SETQ CCREATEDS (FOR CEXT FOUND CCREATED INSIDE (OR COMPILEEXTS *COMPILED-EXTENSIONS*) JOIN (FOR CF IN [OR (LISTP FILES) (FILDIR (PACKFILENAME 'EXTENSION CEXT 'VERSION "" 'BODY '*] WHEN (CDDR (SETQ CCREATED (CREATED-AS CF))) UNLESS (MEMBER CCREATED $$VAL) COLLECT CCREATED))) (* ;; "CCREATEDS is now a list of CREATED-AS items") (FOR CC SF IN CCREATEDS UNLESS (AND [SETQ SF (INFILEP (PACKFILENAME 'EXTENSION NIL 'VERSION NIL 'BODY (CAR CC] (SOURCE-FOR-COMPILED-P (SETQ SF (CREATED-AS SF)) CC DFASLMARGIN)) COLLECT [LIST (CAR CC) (AND SF (LIST (CAR SF) (ROUND (COMPILE-SOURCE-DATE-DIFF CC SF] FINALLY (RETURN (SORT $$VAL (FUNCTION (LAMBDA (CF1 CF2) (ALPHORDER (FILENAMEFIELD (CAR CF1) 'NAME) (FILENAMEFIELD (CAR CF2) 'NAME]) (FIND-SOURCE-FILES [LAMBDA (CFILES SDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (CFILE . SFILES) pairs where CFILE is a Lisp compiled file in CFILES SFILES is a list of source files in SDIRS that CFILE was compiled on.") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ SDIRS (FOR SD INSIDE (OR SDIRS T) COLLECT (DIRECTORYNAME SD))) (SORT (FOR CF SFILES CNAME CCREATED IN (OR (LISTP CFILES) (FILDIR CFILES)) WHEN (AND (SETQ CNAME (INFILEP CF)) (CDDR (SETQ CCREATED (CREATED-AS CF))) (SETQ SFILES (FOR SD SF IN SDIRS WHEN (AND (SETQ SF (INFILEP (PACKFILENAME 'NAME (FILENAMEFIELD CF 'NAME) 'BODY SD))) (SOURCE-FOR-COMPILED-P SF CCREATED DFASLMARGIN)) COLLECT SF))) COLLECT (CONS CNAME SFILES)) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-COMPILED-FILES [LAMBDA (SFILES CDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (SFILE . CFILES) pairs where SFILE is a Lisp source file in SFILES CFILES is a list of compiled files in CDIRS that were compiled on SFILE.") (* ;; "FILEDATE is true for source files and compiled files") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ CDIRS (FOR CD INSIDE (OR CDIRS T) COLLECT (DIRECTORYNAME CD))) (SORT (FOR SF CFILES SNAME SCREATED IN (OR (LISTP SFILES) (FILDIR SFILES)) WHEN [AND (SETQ SNAME (INFILEP SF)) (SETQ SCREATED (CREATED-AS SF)) (NOT (CDDR SCREATED)) (SETQ CFILES (FOR CEXT (ROOT _ (FILENAMEFIELD SNAME 'NAME)) IN *COMPILED-EXTENSIONS* JOIN (FOR CD CF IN CDIRS WHEN (AND (SETQ CF (INFILEP (PACKFILENAME 'NAME ROOT 'EXTENSION CEXT 'BODY CD))) (SOURCE-FOR-COMPILED-P SCREATED CF DFASLMARGIN)) COLLECT CF] COLLECT (CONS SNAME CFILES )) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-UNLOADED-FILES [LAMBDA (FILES) (* ; "Edited 9-Sep-2020 19:35 by rmk:") (* ;; "Returns the files in FILES that don't have FILECREATED properties and presumably are therefore not loaded in the current sysout.") (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (AND (SETQ F (INFILEP (CL:IF (LISTP F) (CAR F) F))) (FILEDATE F)) UNLESS (GETP (FILENAMEFIELD F 'NAME) 'FILEDATES) COLLECT F]) (FIND-LOADED-FILES [LAMBDA (ROOTFILENAMES) (* ; "Edited 19-Sep-2020 07:20 by rmk:") (FOR RN INSIDE ROOTFILENAMES WHEN (GETP RN 'FILEDATES) COLLECT (CONS RN (FOR F IN LOADEDFILELST WHEN (EQ RN (FILENAMEFIELD F 'NAME)) COLLECT F]) (FIND-MULTICOMPILED-FILES [LAMBDA (FILES SHOWINFO) (* ; "Edited 20-Sep-2020 20:57 by rmk:") (* ;; "Returns a list of names for files in FILES that have multiple compilations") (LET (SFILES) (FOR F EXT NAME IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (MEMB (SETQ EXT (FILENAMEFIELD F 'EXTENSION)) *COMPILED-EXTENSIONS*) DO (SETQ NAME (FILENAMEFIELD F 'NAME)) (* ;; "PUSHNEW because we haven't filtered out versions") (PUSHNEW [CDR (OR (ASSOC NAME SFILES) (CAR (PUSH SFILES (CONS NAME] EXT)) (FOR S IN SFILES WHEN (CDDR S) COLLECT (IF SHOWINFO THEN `[,(CAR S) ,(CADAR (FIND-LOADED-FILES (CAR S))) ,(CREATED-AS (CAR S)) ,@(FOR EXT IN (SORT (CDR S)) COLLECT (CREATED-AS (PACKFILENAME 'EXTENSION EXT 'BODY (CAR S] ELSE (CAR S]) ) (DEFINEQ (CREATED-AS [LAMBDA (FILE) (* ; "Edited 20-Sep-2020 23:06 by rmk:") (* ;; "For lisp source files, returns (filecreatename filecreateddate)") (* ;; "For lisp compiled files, returns (cfilename cfiledate sfilecreatename sfilecreateddate)") (* ;; "For other files, (fullfilename NIL)") (* ;; "The cfilename is just the current directory name for DFASLs.") (* ;; "So: (CADR value) is non-NIL for Lisp files. Of those, (CDDR value) is non-NIL for compiled files.") (* ;; "We disable the package delimiter because the atoms in changes may have a packages that we don't know.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (LET (FILEDATE FILENAME SOURCEDATE SOURCENAME LINE POS) [IF (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) THEN (* ; "Managed source or LCOM") (RESETLST [LET (FORM SFORM (RDTBL (FIND-READTABLE "OLD-INTERLISP-FILE"))) (SETQ POS (GETFILEPTR STREAM)) (READCCODE STREAM) (IF (EQ 'DEFINE-FILE-INFO (RATOM STREAM RDTBL)) THEN (* ;; "Reading is package-safe") (SETFILEPTR STREAM POS) (SETQ FORM (READ STREAM RDTBL)) (SETQ RDTBL (FIND-READTABLE (LISTGET (CDR FORM) :READTABLE))) ELSE (SETFILEPTR STREAM POS)) (CL:WHEN (EQ 'PACKAGEDELIM (GETSYNTAX '%: RDTBL)) [RESETSAVE (SETSYNTAX '%: 'OTHER RDTBL) `(SETSYNTAX %: PACKAGEDELIM ,RDTBL]) (* ;; "One way or the other, we're ready for the filecreated") (CL:WHEN (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (SETQ FORM (READ STREAM RDTBL)) (CL:WHEN (MEMB (U-CASE (CAR FORM)) '(FILECREATED IL%:FILECREATED)) (* ;; "IL%%:FILECREATED because we screwed the readtable.") (IF [STREQUAL "compiled on " (CAR (LISTP (CADDR FORM] THEN (* ; "LCOM, get source info") (IF [AND (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (MEMB [U-CASE (CAR (SETQ SFORM (READ STREAM RDTBL] '(FILECREATED IL%:FILECREATED] THEN (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM)) (SETQ SOURCENAME (CADDR SFORM)) (SETQ SOURCEDATE (CADR SFORM)) ELSE (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM))) ELSE (SETQ FILENAME (CADDR FORM)) (SETQ FILEDATE (CADR FORM)))))]) ELSEIF (SETQ POS (STRPOS "XCL Compiler output for source file " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) THEN (* ; "DFASL compiled?") (SETQ SOURCENAME (SUBATOM LINE POS)) (CL:WHEN (SETQ POS (STRPOS "Source file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ SOURCEDATE (GDATE (IDATE (SUBSTRING LINE POS] (CL:WHEN (SETQ POS (STRPOS "FASL file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ FILEDATE (GDATE (IDATE (SUBSTRING LINE POS]))] (* ;; "Revert filenames to Interlisp package if needed:") (CL:WHEN (STRPOS "IL:" FILENAME) (SETQ FILENAME (SUBATOM FILENAME 4))) (CL:WHEN (STRPOS "IL:" SOURCENAME) (SETQ SOURCENAME (MKATOM SOURCENAME 4))) (* ;; "Return DATE NIL if file is not a Lisp file") `(,(OR FILENAME (FULLNAME STREAM)) ,(AND FILEDATE (GDATE (IDATE FILEDATE))) ,@(CL:WHEN SOURCENAME (LIST SOURCENAME (GDATE (IDATE SOURCEDATE))))]) (SOURCE-FOR-COMPILED-P [LAMBDA (SOURCE COMPILED DFASLMARGIN) (* ; "Edited 21-Sep-2020 16:56 by rmk:") (* ;; "There seems to be some variation between the source dates in dfasl files and the filecreated date in the sources, they often don't match exactly. But if they are within DFASLMARGIN, we assume a match. We require exact date match for LCOMS") (* ;; "This is needed for dfasl files created before they recorded the source filecreated name and date instead of the directory source name and date when compile took place.") (* ;; "") (* ;; "DFASLMARGIN is a pair (after before) where we assume a match if the compiled date is no more than after minutes after the source date and no more than before minuts before (the diff is negative then).") (* ;; "A single positive integer x is interpreted as (x 0). A single negative integer x is interpreted as (-x x) (before or after x).") (* ;; "Default is (20 0).") (* ;; "T is positive or negative infinity") (CL:UNLESS (LISTP SOURCE) (SETQ SOURCE (CREATED-AS SOURCE))) (CL:UNLESS (LISTP COMPILED) (SETQ COMPILED (CREATED-AS COMPILED))) (SETQ DFASLMARGIN (IF (NULL DFASLMARGIN) THEN (* ;;  "If compiled is later than source by less than 20 minutes, it's probably OK") '(20 0) ELSEIF (LISTP DFASLMARGIN) ELSEIF (IGREATERP DFASLMARGIN 0) THEN (LIST DFASLMARGIN 0) ELSEIF (MINUSP DFASLMARGIN) THEN (LIST (MINUS DFASLMARGIN) DFASLMARGIN))) (OR (EQUAL (CAR SOURCE) (CADDR COMPILED)) (EQUAL (CADR SOURCE) (CADDDR COMPILED)) (AND [EQ 'DFASL (U-CASE (FILENAMEFIELD (CAR COMPILED) 'EXTENSION] (LET ((TIMEDIFF (COMPILE-SOURCE-DATE-DIFF COMPILED SOURCE))) (* ;; "If compiled was no more than 20 minutes later, it's probably OK. Of no more than DFASLMARGIN earlier, if it is negative.") (AND (OR (EQ T (CAR DFASLMARGIN)) (LEQ TIMEDIFF (CAR DFASLMARGIN))) (OR (EQ T (CADR DFASLMARGIN)) (GEQ TIMEDIFF (CADR DFASLMARGIN]) (COMPILE-SOURCE-DATE-DIFF [LAMBDA (CFILE SFILE) (* ; "Edited 20-Sep-2020 22:59 by rmk:") (* ;; "Positive means that compiled is later than source, normal order but maybe by too much. Negative means that compiled came before source, i.e., compiled on a source that didn't yet exist.") (* ;; "Value is in minutes") (ROUND (FQUOTIENT [IDIFFERENCE [IDATE (CADDDR (OR (LISTP CFILE) (CREATED-AS CFILE] (IDATE (CADR (OR (LISTP SFILE) (CREATED-AS SFILE] (TIMES 60 ONESECOND]) ) (DEFINEQ (FIX-DIRECTORY-DATES [LAMBDA (FILES) (* ; "Edited 6-Sep-2020 15:08 by rmk:") (* ;; "For Lisp source and compiled files, ensures that the directory file date corresponds to the filecreated date. Returns the list of files whose dates were changed.") (* ;; "This allows for the fact that directory dates that are no later than, say, 30 seconds of the filecreated date are probably OK--the directory date may be set when the file is closed.") (* ;; "Use IDATEs in case FDCDATE is not Y2K.") (* ;; "Stop if directory date is more than 2 minutes earlier than the filecreated date. Earlier could be because the dates are asserted at different points in the filing process. But 2 minutes is worth thinking about. Returning from HELP will get them aligned.") (FOR F DIDATE FCDATE IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (SETQ FCDATE (FILEDATE F)) UNLESS (IEQP (SETQ DIDATE (GETFILEINFO F 'ICREATIONDATE)) (SETQ FCDATE (IDATE FCDATE))) COLLECT (CL:WHEN (IGREATERP (IDIFFERENCE FCDATE DIDATE) (ITIMES 120 ONESECOND)) (HELP "DIRECTORY DATE EARLIER THAN FILECREATED DATE" (LIST F (GDATE DIDATE) (GDATE FCDATE)))) (SETFILEINFO F 'ICREATIONDATE FCDATE) F]) (FIX-EQUIV-DATES [LAMBDA (CDENTRIES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "For every entry whose files are EQUIVALENT and whose filedates are different, sets the directory of the file with the later date to be the date of the one with the earlier date. This preumes that the later one must have been a copy. ") (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE EARLY LATE IN (CDR CDENTRIES) WHEN (FETCH EQUIV OF CDE) UNLESS (EQ '= (FETCH DATEREL OF CDE)) COLLECT (SELECTQ (FETCH DATEREL OF CDE) (> (SETQ EARLY (FETCH INFO2 OF CDE)) (SETQ LATE (FETCH INFO1 OF CDE))) (< (SETQ EARLY (FETCH INFO1 OF CDE)) (SETQ LATE (FETCH INFO2 OF CDE))) (SHOULDNT)) (SETFILEINFO (FETCH FULLNAME OF LATE) 'ICREATIONDATE (GETFILEINFO (FETCH FULLNAME OF EARLY) 'ICREATIONDATE)) (FETCH FULLNAME OF LATE]) (COPY-COMPARED-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:20 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO MATCHNAME IN (CDR CDENTRIES) EACHTIME (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) WHEN (AND (FETCH FULLNAME OF SINFO) (FETCH FULLNAME OF TINFO)) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'VERSION NIL 'BODY (FETCH FULLNAME OF TINFO))) MATCHNAME]) (COPY-MISSING-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (CL:UNLESS (STRINGP (CADR (CAR CDENTRIES))) (ERROR "(CAR CDENTRIES) IS NOT A VALID PARAMETER LIST" (CAR CDENTRIES))) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO TDIR MATCHNAME (TDIR _ (CL:IF (EQ TARGET 1) (CAAR CDENTRIES) (CADAR CDENTRIES))) IN (CDR CDENTRIES) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) WHEN (AND (FETCH FULLNAME OF SINFO) (NOT (FETCH FULLNAME OF TINFO))) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (* ;; "Using the source fullname in the target should preserve the version number") (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'BODY TDIR 'BODY (FETCH FULLNAME OF SINFO))) MATCHNAME]) (COMPILED-ON-SAME-SOURCE [LAMBDA (CDENTRIES) (* ; "Edited 9-Sep-2020 13:00 by rmk:") (* ;; "Returms a subset of CDENTRIES consisting of files that are compiled on the same source (i.e. their source names or dates are the same). Preserves the header.") (CDSUBSET CDENTRIES (FUNCTION (LAMBDA (CDE) (DECLARE (USEDFREE INFO1 INFO2)) (LET (CREATED1 CREATED2) (CL:WHEN [AND (EQ 'COMPILED (FETCH TYPE OF INFO1)) (EQ 'COMPILED (FETCH TYPE OF INFO2)) [CDDR (SETQ CREATED1 (CREATED-AS (FETCH FULLNAME OF INFO1] (CDDR (SETQ CREATED2 (CREATED-AS (FETCH FULLNAME OF INFO2] (OR (EQUAL (CADDR CREATED1) (CADDR CREATED2)) (EQUAL (CADDDR CREATED1) (CADDDR CREATED2))))]) ) (RPAQ ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"))) (RPAQ? LASTCDENTRIES NIL) (DEFINEQ (COMPARE-ENTRY-SOURCE-FILES [LAMBDA (CDENTRY LISTSTREAM EXAMINE DW?) (* ; "Edited 30-Aug-2020 12:22 by rmk:") (* ;; "Wrapper to call COMPARESOURCES on the Lisp source files of CDENTRY") (CL:WHEN [AND (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO1 OF CDENTRY))) (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO2 OF CDENTRY] (COMPARESOURCES (FETCH FULLNAME OF (FETCH INFO1 OF CDENTRY)) (FETCH FULLNAME OF (FETCH INFO2 OF CDENTRY)) EXAMINE DW? LISTSTREAM))]) ) (FILESLOAD COMPARESOURCES) (PUTPROPS COMPAREDIRECTORIES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1994 1998 2018 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1680 15255 (COMPAREDIRECTORIES 1690 . 9637) (CDFILES 9639 . 13357) ( COMPAREDIRECTORIES.INFOS 13359 . 14818) (MATCHNAME 14820 . 15253)) (15256 22558 (CDPRINT 15266 . 20045 ) (CDPRINT.LINE 20047 . 22556)) (22559 24311 (CDMAP 22569 . 23265) (CDENTRY 23267 . 23435) (CDSUBSET 23437 . 24309)) (24312 29482 (BINCOMP 24322 . 28250) (EOLTYPE 28252 . 29480)) (29691 42898 ( FIND-UNCOMPILED-FILES 29701 . 33344) (FIND-UNSOURCED-FILES 33346 . 36155) (FIND-SOURCE-FILES 36157 . 37861) (FIND-COMPILED-FILES 37863 . 39941) (FIND-UNLOADED-FILES 39943 . 40687) (FIND-LOADED-FILES 40689 . 41243) (FIND-MULTICOMPILED-FILES 41245 . 42896)) (42899 50931 (CREATED-AS 42909 . 47706) ( SOURCE-FOR-COMPILED-P 47708 . 50236) (COMPILE-SOURCE-DATE-DIFF 50238 . 50929)) (50932 59939 ( FIX-DIRECTORY-DATES 50942 . 52938) (FIX-EQUIV-DATES 52940 . 54200) (COPY-COMPARED-FILES 54202 . 56326) (COPY-MISSING-FILES 56328 . 58167) (COMPILED-ON-SAME-SOURCE 58169 . 59937)) (60094 60705 ( COMPARE-ENTRY-SOURCE-FILES 60104 . 60703))))) STOP \ No newline at end of file diff --git a/lispusers/COMPAREDIRECTORIES.~268~ b/lispusers/COMPAREDIRECTORIES.~268~ deleted file mode 100644 index ffcabcd7..00000000 --- a/lispusers/COMPAREDIRECTORIES.~268~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "13-Oct-2020 22:06:40"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;268 62358 changes to%: (FNS CDFILES BINCOMP COMPAREDIRECTORIES COMPAREDIRECTORIES.INFOS CDPRINT CDPRINT.LINE) (RECORDS CDINFO) previous date%: "12-Oct-2020 20:22:51" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;254) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990, 1994, 1998, 2018, 2020 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COMPAREDIRECTORIESCOMS) (RPAQQ COMPAREDIRECTORIESCOMS ( (* ;; "Compare the contents of two directories.") (FNS COMPAREDIRECTORIES CDFILES COMPAREDIRECTORIES.INFOS MATCHNAME) (FNS CDPRINT CDPRINT.LINE) (FNS CDMAP CDENTRY CDSUBSET) (FNS BINCOMP EOLTYPE) (RECORDS CDENTRY CDINFO) (* ;; "look for compiled files older than the sources") (FNS FIND-UNCOMPILED-FILES FIND-UNSOURCED-FILES FIND-SOURCE-FILES FIND-COMPILED-FILES FIND-UNLOADED-FILES FIND-LOADED-FILES FIND-MULTICOMPILED-FILES) (FNS CREATED-AS SOURCE-FOR-COMPILED-P COMPILE-SOURCE-DATE-DIFF) (FNS FIX-DIRECTORY-DATES FIX-EQUIV-DATES COPY-COMPARED-FILES COPY-MISSING-FILES COMPILED-ON-SAME-SOURCE) [VARS (ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"] (INITVARS (LASTCDENTRIES NIL)) (COMS (FNS COMPARE-ENTRY-SOURCE-FILES) (FILES COMPARESOURCES)))) (* ;; "Compare the contents of two directories.") (DEFINEQ (COMPAREDIRECTORIES [LAMBDA (DIR1 DIR2 SELECT FILEPATTERNS EXTENSIONSTOAVOID USEDIRECTORYDATE OUTPUTFILE ALLVERSIONS) (* ; "Edited 13-Oct-2020 08:43 by rmk:") (* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on DIR1 and DIR2, listing which is newer, or when one is not found on the other. If SELECT is or contains SAME/=, BEFORE/<, AFTER/>, then files where DIR1 is the same as, earlier than, or later than DIR2 are selected. SELECT= NIL is the same as (< >), T is the same as (< > =). Also allows selection based on file-length criteria.") (* ;; "") (* ;; "Unless USEDIRECTORYDATE, comparison is with respect to the the LISP filecreated dates if evailable.") (* ;; "") (* ;; "If OUTPUTFILE is NIL, the list of compared entries is returned. Otherwise the selected entries are printed on OUTPUTFILE (T for the display).") [SETQ SELECT (SELECTQ SELECT (NIL '(< > -* *-)) (T '(< > -* *- =)) (FOR S IN (MKLIST SELECT) COLLECT (SELECTQ S ((AFTER >) '>) ((BEFORE <) '<) ((SAME SAMEDATE =) '=) (AUTHOR 'AUTHOR) (-* '-*) (*- '*-) (ERROR "UNRECOGNIZED SELECT PARAMETER" S] (PROG (INFOS1 INFOS2 CANDIDATES SELECTED COMPAREDATE) [SETQ COMPAREDATE (INTERSECTION SELECT '(< > =] (* ;; "DIRECTORYNAME here to get unrelativized specifications for header.") (SETQ DIR1 (OR (DIRECTORYNAME (OR DIR1 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR1))) (SETQ DIR2 (OR (DIRECTORYNAME (OR DIR2 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR2))) (PRINTOUT T "Comparing " DIR1 6 "vs. " DIR2 T "as of " (DATE) " selecting " SELECT " ... ") (SETQ INFOS1 (COMPAREDIRECTORIES.INFOS (CDFILES DIR1 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS) USEDIRECTORYDATE)) (SETQ INFOS2 (COMPAREDIRECTORIES.INFOS (CDFILES DIR2 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS) USEDIRECTORYDATE)) (CL:UNLESS (AND INFOS2 INFOS1) (RETURN)) (* ;; "At this point the CAR of each info is the atomic match-name. Peel it off to produce candidate entries.") (* ;;  "Look through all of the I2's because multiple versions (if VERSIONS) have the same matchname") [SETQ CANDIDATES (FOR I1 IN INFOS1 JOIN (IF ALLVERSIONS THEN (OR (FOR I2 IN INFOS2 WHEN (EQ (CAR I2) (CAR I1)) COLLECT (LIST (CAR I1) (CDR I1) (CDR I2))) (CONS (LIST (CAR I1) (CDR I1) NIL))) ELSE (CONS (LIST (CAR I1) (CDR I1) (CDR (ASSOC (CAR I1) INFOS2] (* ;; "Could be some 2's without 1's") (SORT [NCONC CANDIDATES (FOR I2 IN INFOS2 UNLESS (ASSOC (CAR I2) CANDIDATES) COLLECT (LIST (CAR I2) NIL (CDR I2] T) (* ;; "CANDIDATES is now a sorted list of the form (matchname entry1 entry2) where an entry consists of (fullname date length author)") (* ;; "Do the SELECT filtering and insert the date relation.") [SETQ SELECTED (FOR C MATCHNAME INFO1 INFO2 IDATE1 IDATE2 DATEREL BINCOMP IN CANDIDATES EACHTIME (SETQ MATCHNAME (POP C)) (SETQ INFO1 (POP C)) (SETQ INFO2 (POP C)) (IF (AND INFO1 INFO2) THEN (SETQ IDATE1 (IDATE (FETCH DATE OF INFO1))) (SETQ IDATE2 (IDATE (FETCH DATE OF INFO2))) (SETQ DATEREL (IF (IGREATERP IDATE1 IDATE2) THEN '> ELSEIF (ILESSP IDATE1 IDATE2) THEN '< ELSE '=)) ELSE (* ;; "Just for printing--no comparison") (SETQ DATEREL '*)) WHEN (IF (AND INFO1 INFO2) THEN (OR (NULL COMPAREDATE) (SELECTQ DATEREL (> (MEMB '> SELECT)) (< (MEMB '< SELECT)) (= (MEMB '= SELECT)) (SHOULDNT))) ELSEIF INFO1 THEN (* ;; "OK if INFO2 is missing?") (MEMB '*- SELECT) ELSE (* ;; "OK if INFO1 is missing?") (MEMB '-* SELECT)) COLLECT (CREATE CDENTRY MATCHNAME _ MATCHNAME INFO1 _ INFO1 DATEREL _ DATEREL INFO2 _ INFO2 EQUIV _ (CL:UNLESS (EQ DATEREL '*) (BINCOMP (FETCH FULLNAME OF INFO1) (FETCH FULLNAME OF INFO2) T (FETCH EOL OF INFO1) (FETCH EOL OF INFO2)))] (PRINTOUT T (LENGTH SELECTED) " entries" T) (PUSH SELECTED (LIST DIR1 DIR2 SELECT (DATE))) (SETQ LASTCDENTRIES SELECTED) (CL:UNLESS OUTPUTFILE (RETURN SELECTED)) (RETURN (CDPRINT SELECTED OUTPUTFILE (MEMB 'AUTHOR SELECT SELECT]) (CDFILES [LAMBDA (DIR FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH) (* ; "Edited 13-Oct-2020 22:06 by rmk:") (* ;; "Returns a list of fullnames for files that satisfy the criteria") (* ;; "For each name returned by (DIRECTORY DIR), assumes that FILEPATTERNS applies to the suffix after the directory (i.e. after NAMEPOS). That includes possibly subdirectories, dotted files in ultimate file names, and versions.") (* ;; " Exclude subdirectories unless FILEPATTERNS includes *>*") (* ;; " Exclude dotted files (.xxx) unless FILEPATTERNS includes .*") (* ;; " Exclude files with extensions in EXTENSIONSTOAVOID (*=NIL does no filtering)") (* ;; " Exclude older versions unless ALLVERSIONS=T") (* ;; " DEPTH is the number of subdirectories below the ones specified in DIR (NIL top-level of DIR only, T = any depth)") (* ;; "Resolve relative directories, so we can suppress subdirectory matches. ") (SETQ EXTENSIONSTOAVOID (MKLIST (U-CASE EXTENSIONSTOAVOID))) [SETQ FILEPATTERNS (MKLIST (OR FILEPATTERNS '*] (FOR FP FN FPNAME FPEXT EXCLUDEDOTTED (TOPDIR _ (DIRECTORYNAME (OR DIR T))) IN FILEPATTERNS JOIN [SETQ FPNAME (U-CASE (FILENAMEFIELD FP 'NAME] [SETQ FPEXT (U-CASE (FILENAMEFIELD FP 'EXTENSION] (CL:UNLESS FPNAME (IF FPEXT THEN (* ;; ".XY") (SETQ FPNAME (PACK* "." FPEXT)) (SETQ FPEXT NIL) ELSE (SETQ FPEXT '*))) (SETQ EXCLUDEDOTTED (NEQ (CHARCODE %.) (CHCON1 FPNAME))) (SETQ FN (PACKFILENAME.STRING 'VERSION (CL:IF ALLVERSIONS '* "") 'DIRECTORY TOPDIR 'NAME '* 'EXTENSION '*)) (* ;; "DEPTH is the number of internal %">%"") [IF (OR (EQ DEPTH T) (STRPOS "*>" FP)) THEN (SETQ DEPTH MAX.SMALLP) ELSEIF DEPTH ELSE (SETQ DEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FN 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT] (CL:UNLESS FPNAME (SETQ FPNAME '*)) (FOR FULLNAME NAME EXT THISDEPTH IN (DIRECTORY FN) EACHTIME [SETQ NAME (U-CASE (FILENAMEFIELD FULLNAME 'NAME] [SETQ EXT (U-CASE (FILENAMEFIELD FULLNAME 'EXTENSION] (CL:UNLESS NAME (IF EXT THEN (* ;; ".XY") (SETQ NAME (PACK* "." EXT)) (SETQ EXT NIL))) (CL:WHEN (AND EXCLUDEDOTTED (EQ (CHARCODE %.) (CHCON1 NAME))) (GO $$ITERATE)) (SETQ THISDEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FULLNAME 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT))) (* ;; "An empty subdirectory may appear without name or extensions") WHEN (AND (OR NAME EXT) (OR (EQ FPNAME '*) (EQ FPNAME NAME)) (OR (EQ FPEXT '*) (EQ FPEXT EXT))) UNLESS [OR (IGREATERP THISDEPTH DEPTH) (AND EXT (OR (MEMB '* EXTENSIONSTOAVOID) (MEMB EXT EXTENSIONSTOAVOID] COLLECT FULLNAME) FINALLY (CL:UNLESS $$VAL (PRINTOUT T "No relevant files in " TOPDIR T]) (COMPAREDIRECTORIES.INFOS [LAMBDA (FILES USEDIRECTORYDATE) (* ; "Edited 13-Oct-2020 08:42 by rmk:") (* ;; "Value is a list of CDINFOS with the match-name consed on to the front") (FOR FULLNAME TYPE LDATE IN FILES COLLECT (* ;; "GDATE/IDATE in case Y2K") (SETQ LDATE (FILEDATE FULLNAME)) (* ; "Is it a Lisp file?") (CONS (MATCHNAME FULLNAME) (CREATE CDINFO FULLNAME _ FULLNAME DATE _ [GDATE (IDATE (IF USEDIRECTORYDATE THEN (GETFILEINFO FULLNAME 'CREATIONDATE) ELSEIF (OR LDATE (GETFILEINFO FULLNAME 'CREATIONDATE] LENGTH _ (GETFILEINFO FULLNAME 'LENGTH) AUTHOR _ (GETFILEINFO FULLNAME 'AUTHOR) TYPE _ (IF LDATE THEN (CL:IF (MEMB (FILENAMEFIELD FULLNAME 'EXTENSION) *COMPILED-EXTENSIONS*) 'COMPILED 'SOURCE) ELSE (PRINTFILETYPE FULLNAME)) EOL _ (EOLTYPE FULLNAME]) (MATCHNAME [LAMBDA (NAME) (* ; "Edited 5-Sep-2020 13:41 by rmk:") (* ;; "The NAME.DIR for matching related files") (LET ((M (PACKFILENAME 'HOST NIL 'VERSION NIL 'DIRECTORY NIL 'BODY NAME))) (* ;; "Strip off the nuisance period") (CL:IF (EQ (CHARCODE %.) (NTHCHARCODE M -1)) (SUBATOM M 1 -2) M)]) ) (DEFINEQ (CDPRINT [LAMBDA (CDENTRIES FILE PRINTAUTHOR) (* ; "Edited 13-Oct-2020 08:38 by rmk:") (* ;; "Typically CDENTRIES will have a header. If not, we fake one up, at least for the directories and today's date.") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (RESETLST (LET (INFO1 TEXT STREAM DATE1POS ENDDATE1 DIR1 DIR2 (HEADER (CAR CDENTRIES)) NCHARSDIR1) (CL:UNLESS (STRINGP (CADR HEADER)) (SETQ HEADER (LIST [FOR E IN CDENTRIES WHEN (FETCH INFO1 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO1 OF E] [FOR E IN CDENTRIES WHEN (FETCH INFO2 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO2 OF E] NIL (DATE))) (PUSH CDENTRIES HEADER)) (SETQ DIR1 (CAR HEADER)) (SETQ NCHARSDIR1 (NCHARS DIR1)) (SETQ DIR2 (CADR HEADER)) (CL:UNLESS (SETQ STREAM (GETSTREAM FILE 'OUTPUT T)) [RESETSAVE (SETQ STREAM (OPENSTREAM (PACKFILENAME 'EXTENSION 'TXT 'BODY FILE) 'OUTPUT 'NEW)) '(PROGN (CLOSEF? OLDVALUE]) (CL:WHEN DIR1 (PRINTOUT STREAM "Comparing " DIR1 6 "vs. " DIR2 T "as of " (CADDDR HEADER)) (CL:WHEN (CADDR HEADER) (PRINTOUT STREAM " selecting " (CADDR HEADER))) (PRINTOUT STREAM -2 (LENGTH (CDR CDENTRIES)) " entries" T T)) (LINELENGTH 1000 STREAM) (* ; "Don't wrap") (* ;; "DATE1POS is the position of the first character of INFO1's date, used for tabbing. We have to measure the filename, date, size, and author if desired") (IF (CDR CDENTRIES) THEN (FOR E INFO1 (MAXDATE1WIDTH _ 0) (SPACEWIDTH _ 1) (PARENWIDTH _ 2) IN (CDR CDENTRIES) WHEN (SETQ INFO1 (FETCH INFO1 OF E)) LARGEST [SETQ MAXDATE1WIDTH (IMAX MAXDATE1WIDTH (NCHARS (FETCH DATE OF INFO1] (IPLUS (- (NCHARS (FETCH FULLNAME OF INFO1)) NCHARSDIR1) (NCHARS (FETCH LENGTH OF INFO1)) (CL:IF PRINTAUTHOR (IPLUS SPACEWIDTH PARENWIDTH (NCHARS (FETCH AUTHOR OF INFO1))) 0)) FINALLY (* ;;  "First 4 for width of equiv. $$EXTREME is NIL if there are no INFO1's") (SETQ DATE1POS (IPLUS (OR $$EXTREME 10) 4 (ITIMES 3 SPACEWIDTH))) (SETQ ENDDATE1 (IPLUS DATE1POS MAXDATE1WIDTH) )) (FOR E IN (CDR CDENTRIES) DO (CDPRINT.LINE STREAM E PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 (NCHARS DIR2))) ELSE (PRINTOUT T "CDENTRIES is empty" T)) (AND STREAM (CLOSEF? STREAM))))]) (CDPRINT.LINE [LAMBDA (STREAM ENTRY PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 NCHARSDIR2) (* ; "Edited 13-Oct-2020 08:51 by rmk:") (* ;; "Format one line of the directory comparison listing. If PRINTAUTHOR and AUTHOR1 or AUTHOR2 are non-NIL, list the author in parens; otherwise omit it.") (LET ((INFO1 (FETCH INFO1 OF ENTRY)) (INFO2 (FETCH INFO2 OF ENTRY))) (PRINTOUT STREAM (SELECTQ (FETCH EQUIV OF ENTRY) (T "==") (NIL " ") (PROGN (SELECTQ (FETCH EOL OF INFO1) (CR 'C) (LF 'L) (CRLF 2) " ") (SELECTQ (FETCH EOL OF INFO2) (CR 'C) (LF 'L) (CRLF 2) " "))) " ") (CL:WHEN INFO1 (PRINTOUT STREAM (SUBSTRING (FETCH FULLNAME OF INFO1) (ADD1 NCHARSDIR1) NIL (CONSTANT (CONCAT))) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO1) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO1) .TAB0 DATE1POS (FETCH DATE OF INFO1))) (PRINTOUT STREAM .TAB0 ENDDATE1 " " (FETCH DATEREL OF ENTRY) " ") (CL:WHEN INFO2 (PRINTOUT STREAM (FETCH DATE OF INFO2) " " (SUBSTRING (FETCH FULLNAME OF INFO2) (ADD1 NCHARSDIR2) NIL (CONSTANT (CONCAT))) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO2) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO2))) (TERPRI STREAM]) ) (DEFINEQ (CDMAP [LAMBDA (CDENTRIES FN) (* ; "Edited 6-Sep-2020 15:58 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) DO (APPLY* FN CDE]) (CDENTRY [LAMBDA (MATCHNAME CDENTRIES) (* ; "Edited 5-Sep-2020 21:09 by rmk:") (ASSOC MATCHNAME (OR CDENTRIES LASTCDENTRIES]) (CDSUBSET [LAMBDA (CDENTRIES FN) (* ; "Edited 15-Sep-2020 13:49 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (CONS (CAR CDENTRIES) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) WHEN (APPLY* FN CDE) COLLECT CDE]) ) (DEFINEQ (BINCOMP [LAMBDA (FILE1 FILE2 EOLDIFFOK EOL1 EOL2) (* ; "Edited 13-Oct-2020 08:53 by rmk:") (* ;; "Returns T if FILE1 and FILE2 are byte-equivalent. Returns EOLDIFF if they are byte equivalent except for CR/LF/CRLF exchanges. ") (* ;; "If EOLDIFFOK, return indicates that the files are the same except for EOL mappings. If EOL1 and EOL2 are not provided, they are computed here.") (IF (IEQP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) THEN [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (* ;; "Simpler code to recompute eol's even if provided") (BIND B1 B2 EOL1 EOL2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS (AND EOLDIFFOK (SELCHARQ B1 (CR (CL:WHEN (EQ EOL1 'LF) (RETURN NIL)) (SETQ EOL1 'CR) (SETQ EOL2 'LF) (EQ B2 (CHARCODE LF))) (LF (CL:WHEN (EQ EOL1 'CR) (RETURN NIL)) (SETQ EOL1 'LF) (SETQ EOL2 'CR) (EQ B2 (CHARCODE CR))) NIL)) (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T] ELSEIF EOLDIFFOK THEN (* ;; "Lengths are different possibly because of CRLF to CR/LF substitutions.") (* ;;  "More complex code could detect the EOLTYPE incrementally without separate passes, but ...") (CL:UNLESS EOL1 (SETQ EOL1 (EOLTYPE FILE1))) (CL:UNLESS EOL2 (SETQ EOL2 (EOLTYPE FILE2))) (CL:WHEN (IF [AND (EQ EOL1 'CRLF) (MEMB EOL2 '(LF CR] ELSEIF [AND (EQ EOL2 'CRLF) (MEMB EOL1 '(LF CR] THEN (SWAP FILE1 FILE2)) (* ;; "FILE1 is now CRLF, FILE2 is not. If FILE1 isn't longer, it can't have a CRLF that corresponds to a CR or LF.") (CL:WHEN (IGREATERP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND B1 B2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS [AND (EQ (CHARCODE CR) B1) (EQ (CHARCODE LF) (\BIN STREAM1)) (MEMB B2 (CHARCODE (CR LF] (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T]))]) (EOLTYPE [LAMBDA (FILE) (* ; "Edited 3-Sep-2020 17:05 by rmk:") (* ;; "Returns the EOLCONVENTION of FILE if it only sees one kind, NIL if it can't decide.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (SETFILEINFO STREAM 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND EOLTYPE DO (SELCHARQ (OR (\BIN STREAM) (RETURN EOLTYPE)) (CR (IF (EQ (CHARCODE LF) (\PEEKBIN STREAM T)) THEN (CL:WHEN (MEMB EOLTYPE '(LF CR)) (RETURN NIL)) (\BIN STREAM) (SETQ EOLTYPE 'CRLF) ELSEIF (MEMB EOLTYPE '(LF CRLF)) THEN (RETURN NIL) ELSE (SETQ EOLTYPE 'CR))) (LF (CL:WHEN (MEMB EOLTYPE '(CR CRLF)) (RETURN NIL)) (SETQ EOLTYPE 'LF)) NIL]) ) (DECLARE%: EVAL@COMPILE (RECORD CDENTRY (MATCHNAME INFO1 DATEREL INFO2 . EQUIV)) (RECORD CDINFO (FULLNAME DATE LENGTH AUTHOR TYPE EOL)) ) (* ;; "look for compiled files older than the sources") (DEFINEQ (FIND-UNCOMPILED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 20-Sep-2020 23:04 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;; "Produces a list of the source files in FILES that have no corresponding compiled file") (* ;; "This determines whether there is at least one compiled file. If there are two or more, that's a problem") (* ;; "We want the most recent version only") (* ;; "Source files have a 2-element created-as with a non-NIL date") (SETQ FILES (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) UNLESS (MEMB (SETQ F (PACKFILENAME 'VERSION NIL 'BODY F)) $$VAL) COLLECT F)) (FOR F SCREATION FILES IN FILES WHEN (AND (CADR (SETQ SCREATION (CREATED-AS F))) (NOT (CDDR SCREATION))) WHEN [SETQ FILES (FOR CEXT CF IN (OR COMPILEEXTS *COMPILED-EXTENSIONS*) WHEN (SETQ CF (INFILEP (PACKFILENAME 'EXTENSION CEXT 'VERSION NIL 'BODY F))) COLLECT (CL:WHEN (SOURCE-FOR-COMPILED-P SCREATION CF DFASLMARGIN) (RETURN NIL)) CF FINALLY (* ;; "If we found some compiled files, they weren't on this source. If there weren't any compiled files to check, maybe there weren't any functions.") (* ;;  "NLSETQ because we don't want to stop if there is an error, typically from a package problem") (RETURN (OR $$VAL (LET [(FCOMS (CAR (NLSETQ (GETDEF (FILECOMS F) 'VARS F] (IF (NULL FCOMS) THEN (* ;;  "GETDEF caused an error. Maybe a package problem. ") (AND NIL 'NOCOMMANDS) ELSEIF (INFILECOMS? NIL '(FUNCTIONS FNS) FCOMS) THEN T] COLLECT (CONS F (SELECTQ FILES (T NIL) (NOCOMMANDS (CONS "No commands")) (FOR CF IN FILES COLLECT (* ;;  "Positive means that compiled is later than source, normal order but maybe by too much.") (* ;;  "Negative means that compiled came before source. Odd") (LIST CF (COMPILE-SOURCE-DATE-DIFF CF SCREATION]) (FIND-UNSOURCED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 15-Sep-2020 15:32 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;;  "Produces a list of compiled FILES for which no source file can be found in the same directory.") (* ;; "The source date in at least one DFASL was off by a second, maybe some sort of IDATE rounding? So, give a margin.") (* ;; "We want the most recent version only. Check CREATED-AS to make sure it really is a compiled file.") (* ;; "Sort to get lcoms and dfasls next to each other.") (LET (CCREATEDS) (SETQ CCREATEDS (FOR CEXT FOUND CCREATED INSIDE (OR COMPILEEXTS *COMPILED-EXTENSIONS*) JOIN (FOR CF IN [OR (LISTP FILES) (FILDIR (PACKFILENAME 'EXTENSION CEXT 'VERSION "" 'BODY '*] WHEN (CDDR (SETQ CCREATED (CREATED-AS CF))) UNLESS (MEMBER CCREATED $$VAL) COLLECT CCREATED))) (* ;; "CCREATEDS is now a list of CREATED-AS items") (FOR CC SF IN CCREATEDS UNLESS (AND [SETQ SF (INFILEP (PACKFILENAME 'EXTENSION NIL 'VERSION NIL 'BODY (CAR CC] (SOURCE-FOR-COMPILED-P (SETQ SF (CREATED-AS SF)) CC DFASLMARGIN)) COLLECT [LIST (CAR CC) (AND SF (LIST (CAR SF) (ROUND (COMPILE-SOURCE-DATE-DIFF CC SF] FINALLY (RETURN (SORT $$VAL (FUNCTION (LAMBDA (CF1 CF2) (ALPHORDER (FILENAMEFIELD (CAR CF1) 'NAME) (FILENAMEFIELD (CAR CF2) 'NAME]) (FIND-SOURCE-FILES [LAMBDA (CFILES SDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (CFILE . SFILES) pairs where CFILE is a Lisp compiled file in CFILES SFILES is a list of source files in SDIRS that CFILE was compiled on.") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ SDIRS (FOR SD INSIDE (OR SDIRS T) COLLECT (DIRECTORYNAME SD))) (SORT (FOR CF SFILES CNAME CCREATED IN (OR (LISTP CFILES) (FILDIR CFILES)) WHEN (AND (SETQ CNAME (INFILEP CF)) (CDDR (SETQ CCREATED (CREATED-AS CF))) (SETQ SFILES (FOR SD SF IN SDIRS WHEN (AND (SETQ SF (INFILEP (PACKFILENAME 'NAME (FILENAMEFIELD CF 'NAME) 'BODY SD))) (SOURCE-FOR-COMPILED-P SF CCREATED DFASLMARGIN)) COLLECT SF))) COLLECT (CONS CNAME SFILES)) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-COMPILED-FILES [LAMBDA (SFILES CDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (SFILE . CFILES) pairs where SFILE is a Lisp source file in SFILES CFILES is a list of compiled files in CDIRS that were compiled on SFILE.") (* ;; "FILEDATE is true for source files and compiled files") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ CDIRS (FOR CD INSIDE (OR CDIRS T) COLLECT (DIRECTORYNAME CD))) (SORT (FOR SF CFILES SNAME SCREATED IN (OR (LISTP SFILES) (FILDIR SFILES)) WHEN [AND (SETQ SNAME (INFILEP SF)) (SETQ SCREATED (CREATED-AS SF)) (NOT (CDDR SCREATED)) (SETQ CFILES (FOR CEXT (ROOT _ (FILENAMEFIELD SNAME 'NAME)) IN *COMPILED-EXTENSIONS* JOIN (FOR CD CF IN CDIRS WHEN (AND (SETQ CF (INFILEP (PACKFILENAME 'NAME ROOT 'EXTENSION CEXT 'BODY CD))) (SOURCE-FOR-COMPILED-P SCREATED CF DFASLMARGIN)) COLLECT CF] COLLECT (CONS SNAME CFILES )) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-UNLOADED-FILES [LAMBDA (FILES) (* ; "Edited 9-Sep-2020 19:35 by rmk:") (* ;; "Returns the files in FILES that don't have FILECREATED properties and presumably are therefore not loaded in the current sysout.") (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (AND (SETQ F (INFILEP (CL:IF (LISTP F) (CAR F) F))) (FILEDATE F)) UNLESS (GETP (FILENAMEFIELD F 'NAME) 'FILEDATES) COLLECT F]) (FIND-LOADED-FILES [LAMBDA (ROOTFILENAMES) (* ; "Edited 19-Sep-2020 07:20 by rmk:") (FOR RN INSIDE ROOTFILENAMES WHEN (GETP RN 'FILEDATES) COLLECT (CONS RN (FOR F IN LOADEDFILELST WHEN (EQ RN (FILENAMEFIELD F 'NAME)) COLLECT F]) (FIND-MULTICOMPILED-FILES [LAMBDA (FILES SHOWINFO) (* ; "Edited 20-Sep-2020 20:57 by rmk:") (* ;; "Returns a list of names for files in FILES that have multiple compilations") (LET (SFILES) (FOR F EXT NAME IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (MEMB (SETQ EXT (FILENAMEFIELD F 'EXTENSION)) *COMPILED-EXTENSIONS*) DO (SETQ NAME (FILENAMEFIELD F 'NAME)) (* ;; "PUSHNEW because we haven't filtered out versions") (PUSHNEW [CDR (OR (ASSOC NAME SFILES) (CAR (PUSH SFILES (CONS NAME] EXT)) (FOR S IN SFILES WHEN (CDDR S) COLLECT (IF SHOWINFO THEN `[,(CAR S) ,(CADAR (FIND-LOADED-FILES (CAR S))) ,(CREATED-AS (CAR S)) ,@(FOR EXT IN (SORT (CDR S)) COLLECT (CREATED-AS (PACKFILENAME 'EXTENSION EXT 'BODY (CAR S] ELSE (CAR S]) ) (DEFINEQ (CREATED-AS [LAMBDA (FILE) (* ; "Edited 20-Sep-2020 23:06 by rmk:") (* ;; "For lisp source files, returns (filecreatename filecreateddate)") (* ;; "For lisp compiled files, returns (cfilename cfiledate sfilecreatename sfilecreateddate)") (* ;; "For other files, (fullfilename NIL)") (* ;; "The cfilename is just the current directory name for DFASLs.") (* ;; "So: (CADR value) is non-NIL for Lisp files. Of those, (CDDR value) is non-NIL for compiled files.") (* ;; "We disable the package delimiter because the atoms in changes may have a packages that we don't know.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (LET (FILEDATE FILENAME SOURCEDATE SOURCENAME LINE POS) [IF (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) THEN (* ; "Managed source or LCOM") (RESETLST [LET (FORM SFORM (RDTBL (FIND-READTABLE "OLD-INTERLISP-FILE"))) (SETQ POS (GETFILEPTR STREAM)) (READCCODE STREAM) (IF (EQ 'DEFINE-FILE-INFO (RATOM STREAM RDTBL)) THEN (* ;; "Reading is package-safe") (SETFILEPTR STREAM POS) (SETQ FORM (READ STREAM RDTBL)) (SETQ RDTBL (FIND-READTABLE (LISTGET (CDR FORM) :READTABLE))) ELSE (SETFILEPTR STREAM POS)) (CL:WHEN (EQ 'PACKAGEDELIM (GETSYNTAX '%: RDTBL)) [RESETSAVE (SETSYNTAX '%: 'OTHER RDTBL) `(SETSYNTAX %: PACKAGEDELIM ,RDTBL]) (* ;; "One way or the other, we're ready for the filecreated") (CL:WHEN (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (SETQ FORM (READ STREAM RDTBL)) (CL:WHEN (MEMB (U-CASE (CAR FORM)) '(FILECREATED IL%:FILECREATED)) (* ;; "IL%%:FILECREATED because we screwed the readtable.") (IF [STREQUAL "compiled on " (CAR (LISTP (CADDR FORM] THEN (* ; "LCOM, get source info") (IF [AND (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (MEMB [U-CASE (CAR (SETQ SFORM (READ STREAM RDTBL] '(FILECREATED IL%:FILECREATED] THEN (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM)) (SETQ SOURCENAME (CADDR SFORM)) (SETQ SOURCEDATE (CADR SFORM)) ELSE (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM))) ELSE (SETQ FILENAME (CADDR FORM)) (SETQ FILEDATE (CADR FORM)))))]) ELSEIF (SETQ POS (STRPOS "XCL Compiler output for source file " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) THEN (* ; "DFASL compiled?") (SETQ SOURCENAME (SUBATOM LINE POS)) (CL:WHEN (SETQ POS (STRPOS "Source file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ SOURCEDATE (GDATE (IDATE (SUBSTRING LINE POS] (CL:WHEN (SETQ POS (STRPOS "FASL file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ FILEDATE (GDATE (IDATE (SUBSTRING LINE POS]))] (* ;; "Revert filenames to Interlisp package if needed:") (CL:WHEN (STRPOS "IL:" FILENAME) (SETQ FILENAME (SUBATOM FILENAME 4))) (CL:WHEN (STRPOS "IL:" SOURCENAME) (SETQ SOURCENAME (MKATOM SOURCENAME 4))) (* ;; "Return DATE NIL if file is not a Lisp file") `(,(OR FILENAME (FULLNAME STREAM)) ,(AND FILEDATE (GDATE (IDATE FILEDATE))) ,@(CL:WHEN SOURCENAME (LIST SOURCENAME (GDATE (IDATE SOURCEDATE))))]) (SOURCE-FOR-COMPILED-P [LAMBDA (SOURCE COMPILED DFASLMARGIN) (* ; "Edited 21-Sep-2020 16:56 by rmk:") (* ;; "There seems to be some variation between the source dates in dfasl files and the filecreated date in the sources, they often don't match exactly. But if they are within DFASLMARGIN, we assume a match. We require exact date match for LCOMS") (* ;; "This is needed for dfasl files created before they recorded the source filecreated name and date instead of the directory source name and date when compile took place.") (* ;; "") (* ;; "DFASLMARGIN is a pair (after before) where we assume a match if the compiled date is no more than after minutes after the source date and no more than before minuts before (the diff is negative then).") (* ;; "A single positive integer x is interpreted as (x 0). A single negative integer x is interpreted as (-x x) (before or after x).") (* ;; "Default is (20 0).") (* ;; "T is positive or negative infinity") (CL:UNLESS (LISTP SOURCE) (SETQ SOURCE (CREATED-AS SOURCE))) (CL:UNLESS (LISTP COMPILED) (SETQ COMPILED (CREATED-AS COMPILED))) (SETQ DFASLMARGIN (IF (NULL DFASLMARGIN) THEN (* ;;  "If compiled is later than source by less than 20 minutes, it's probably OK") '(20 0) ELSEIF (LISTP DFASLMARGIN) ELSEIF (IGREATERP DFASLMARGIN 0) THEN (LIST DFASLMARGIN 0) ELSEIF (MINUSP DFASLMARGIN) THEN (LIST (MINUS DFASLMARGIN) DFASLMARGIN))) (OR (EQUAL (CAR SOURCE) (CADDR COMPILED)) (EQUAL (CADR SOURCE) (CADDDR COMPILED)) (AND [EQ 'DFASL (U-CASE (FILENAMEFIELD (CAR COMPILED) 'EXTENSION] (LET ((TIMEDIFF (COMPILE-SOURCE-DATE-DIFF COMPILED SOURCE))) (* ;; "If compiled was no more than 20 minutes later, it's probably OK. Of no more than DFASLMARGIN earlier, if it is negative.") (AND (OR (EQ T (CAR DFASLMARGIN)) (LEQ TIMEDIFF (CAR DFASLMARGIN))) (OR (EQ T (CADR DFASLMARGIN)) (GEQ TIMEDIFF (CADR DFASLMARGIN]) (COMPILE-SOURCE-DATE-DIFF [LAMBDA (CFILE SFILE) (* ; "Edited 20-Sep-2020 22:59 by rmk:") (* ;; "Positive means that compiled is later than source, normal order but maybe by too much. Negative means that compiled came before source, i.e., compiled on a source that didn't yet exist.") (* ;; "Value is in minutes") (ROUND (FQUOTIENT [IDIFFERENCE [IDATE (CADDDR (OR (LISTP CFILE) (CREATED-AS CFILE] (IDATE (CADR (OR (LISTP SFILE) (CREATED-AS SFILE] (TIMES 60 ONESECOND]) ) (DEFINEQ (FIX-DIRECTORY-DATES [LAMBDA (FILES) (* ; "Edited 6-Sep-2020 15:08 by rmk:") (* ;; "For Lisp source and compiled files, ensures that the directory file date corresponds to the filecreated date. Returns the list of files whose dates were changed.") (* ;; "This allows for the fact that directory dates that are no later than, say, 30 seconds of the filecreated date are probably OK--the directory date may be set when the file is closed.") (* ;; "Use IDATEs in case FDCDATE is not Y2K.") (* ;; "Stop if directory date is more than 2 minutes earlier than the filecreated date. Earlier could be because the dates are asserted at different points in the filing process. But 2 minutes is worth thinking about. Returning from HELP will get them aligned.") (FOR F DIDATE FCDATE IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (SETQ FCDATE (FILEDATE F)) UNLESS (IEQP (SETQ DIDATE (GETFILEINFO F 'ICREATIONDATE)) (SETQ FCDATE (IDATE FCDATE))) COLLECT (CL:WHEN (IGREATERP (IDIFFERENCE FCDATE DIDATE) (ITIMES 120 ONESECOND)) (HELP "DIRECTORY DATE EARLIER THAN FILECREATED DATE" (LIST F (GDATE DIDATE) (GDATE FCDATE)))) (SETFILEINFO F 'ICREATIONDATE FCDATE) F]) (FIX-EQUIV-DATES [LAMBDA (CDENTRIES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "For every entry whose files are EQUIVALENT and whose filedates are different, sets the directory of the file with the later date to be the date of the one with the earlier date. This preumes that the later one must have been a copy. ") (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE EARLY LATE IN (CDR CDENTRIES) WHEN (FETCH EQUIV OF CDE) UNLESS (EQ '= (FETCH DATEREL OF CDE)) COLLECT (SELECTQ (FETCH DATEREL OF CDE) (> (SETQ EARLY (FETCH INFO2 OF CDE)) (SETQ LATE (FETCH INFO1 OF CDE))) (< (SETQ EARLY (FETCH INFO1 OF CDE)) (SETQ LATE (FETCH INFO2 OF CDE))) (SHOULDNT)) (SETFILEINFO (FETCH FULLNAME OF LATE) 'ICREATIONDATE (GETFILEINFO (FETCH FULLNAME OF EARLY) 'ICREATIONDATE)) (FETCH FULLNAME OF LATE]) (COPY-COMPARED-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:20 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO MATCHNAME IN (CDR CDENTRIES) EACHTIME (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) WHEN (AND (FETCH FULLNAME OF SINFO) (FETCH FULLNAME OF TINFO)) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'VERSION NIL 'BODY (FETCH FULLNAME OF TINFO))) MATCHNAME]) (COPY-MISSING-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (CL:UNLESS (STRINGP (CADR (CAR CDENTRIES))) (ERROR "(CAR CDENTRIES) IS NOT A VALID PARAMETER LIST" (CAR CDENTRIES))) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO TDIR MATCHNAME (TDIR _ (CL:IF (EQ TARGET 1) (CAAR CDENTRIES) (CADAR CDENTRIES))) IN (CDR CDENTRIES) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) WHEN (AND (FETCH FULLNAME OF SINFO) (NOT (FETCH FULLNAME OF TINFO))) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (* ;; "Using the source fullname in the target should preserve the version number") (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'BODY TDIR 'BODY (FETCH FULLNAME OF SINFO))) MATCHNAME]) (COMPILED-ON-SAME-SOURCE [LAMBDA (CDENTRIES) (* ; "Edited 9-Sep-2020 13:00 by rmk:") (* ;; "Returms a subset of CDENTRIES consisting of files that are compiled on the same source (i.e. their source names or dates are the same). Preserves the header.") (CDSUBSET CDENTRIES (FUNCTION (LAMBDA (CDE) (DECLARE (USEDFREE INFO1 INFO2)) (LET (CREATED1 CREATED2) (CL:WHEN [AND (EQ 'COMPILED (FETCH TYPE OF INFO1)) (EQ 'COMPILED (FETCH TYPE OF INFO2)) [CDDR (SETQ CREATED1 (CREATED-AS (FETCH FULLNAME OF INFO1] (CDDR (SETQ CREATED2 (CREATED-AS (FETCH FULLNAME OF INFO2] (OR (EQUAL (CADDR CREATED1) (CADDR CREATED2)) (EQUAL (CADDDR CREATED1) (CADDDR CREATED2))))]) ) (RPAQ ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"))) (RPAQ? LASTCDENTRIES NIL) (DEFINEQ (COMPARE-ENTRY-SOURCE-FILES [LAMBDA (CDENTRY LISTSTREAM EXAMINE DW?) (* ; "Edited 30-Aug-2020 12:22 by rmk:") (* ;; "Wrapper to call COMPARESOURCES on the Lisp source files of CDENTRY") (CL:WHEN [AND (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO1 OF CDENTRY))) (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO2 OF CDENTRY] (COMPARESOURCES (FETCH FULLNAME OF (FETCH INFO1 OF CDENTRY)) (FETCH FULLNAME OF (FETCH INFO2 OF CDENTRY)) EXAMINE DW? LISTSTREAM))]) ) (FILESLOAD COMPARESOURCES) (PUTPROPS COMPAREDIRECTORIES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1994 1998 2018 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1751 16493 (COMPAREDIRECTORIES 1761 . 9870) (CDFILES 9872 . 14539) ( COMPAREDIRECTORIES.INFOS 14541 . 16056) (MATCHNAME 16058 . 16491)) (16494 23679 (CDPRINT 16504 . 21304 ) (CDPRINT.LINE 21306 . 23677)) (23680 25432 (CDMAP 23690 . 24386) (CDENTRY 24388 . 24556) (CDSUBSET 24558 . 25430)) (25433 30964 (BINCOMP 25443 . 29732) (EOLTYPE 29734 . 30962)) (31177 44384 ( FIND-UNCOMPILED-FILES 31187 . 34830) (FIND-UNSOURCED-FILES 34832 . 37641) (FIND-SOURCE-FILES 37643 . 39347) (FIND-COMPILED-FILES 39349 . 41427) (FIND-UNLOADED-FILES 41429 . 42173) (FIND-LOADED-FILES 42175 . 42729) (FIND-MULTICOMPILED-FILES 42731 . 44382)) (44385 52417 (CREATED-AS 44395 . 49192) ( SOURCE-FOR-COMPILED-P 49194 . 51722) (COMPILE-SOURCE-DATE-DIFF 51724 . 52415)) (52418 61425 ( FIX-DIRECTORY-DATES 52428 . 54424) (FIX-EQUIV-DATES 54426 . 55686) (COPY-COMPARED-FILES 55688 . 57812) (COPY-MISSING-FILES 57814 . 59653) (COMPILED-ON-SAME-SOURCE 59655 . 61423)) (61580 62191 ( COMPARE-ENTRY-SOURCE-FILES 61590 . 62189))))) STOP \ No newline at end of file diff --git a/lispusers/COMPAREDIRECTORIES.~269~ b/lispusers/COMPAREDIRECTORIES.~269~ deleted file mode 100644 index 1e54129c..00000000 --- a/lispusers/COMPAREDIRECTORIES.~269~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "14-Oct-2020 21:18:16"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;269 62551 changes to%: (FNS COMPAREDIRECTORIES CDFILES) previous date%: "13-Oct-2020 22:06:40" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;268) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990, 1994, 1998, 2018, 2020 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COMPAREDIRECTORIESCOMS) (RPAQQ COMPAREDIRECTORIESCOMS ( (* ;; "Compare the contents of two directories.") (FNS COMPAREDIRECTORIES CDFILES COMPAREDIRECTORIES.INFOS MATCHNAME) (FNS CDPRINT CDPRINT.LINE) (FNS CDMAP CDENTRY CDSUBSET) (FNS BINCOMP EOLTYPE) (RECORDS CDENTRY CDINFO) (* ;; "look for compiled files older than the sources") (FNS FIND-UNCOMPILED-FILES FIND-UNSOURCED-FILES FIND-SOURCE-FILES FIND-COMPILED-FILES FIND-UNLOADED-FILES FIND-LOADED-FILES FIND-MULTICOMPILED-FILES) (FNS CREATED-AS SOURCE-FOR-COMPILED-P COMPILE-SOURCE-DATE-DIFF) (FNS FIX-DIRECTORY-DATES FIX-EQUIV-DATES COPY-COMPARED-FILES COPY-MISSING-FILES COMPILED-ON-SAME-SOURCE) [VARS (ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"] (INITVARS (LASTCDENTRIES NIL)) (COMS (FNS COMPARE-ENTRY-SOURCE-FILES) (FILES COMPARESOURCES)))) (* ;; "Compare the contents of two directories.") (DEFINEQ (COMPAREDIRECTORIES [LAMBDA (DIR1 DIR2 SELECT FILEPATTERNS EXTENSIONSTOAVOID USEDIRECTORYDATE OUTPUTFILE ALLVERSIONS) (* ; "Edited 14-Oct-2020 21:15 by rmk:") (* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on DIR1 and DIR2, listing which is newer, or when one is not found on the other. If SELECT is or contains SAME/=, BEFORE/<, AFTER/>, then files where DIR1 is the same as, earlier than, or later than DIR2 are selected. SELECT= NIL is the same as (< >), T is the same as (< > =). Also allows selection based on file-length criteria.") (* ;; "") (* ;; "Unless USEDIRECTORYDATE, comparison is with respect to the the LISP filecreated dates if evailable.") (* ;; "") (* ;; "If OUTPUTFILE is NIL, the list of compared entries is returned. Otherwise the selected entries are printed on OUTPUTFILE (T for the display).") [SETQ SELECT (SELECTQ SELECT (NIL '(< > -* *-)) (T '(< > -* *- =)) (FOR S IN (MKLIST SELECT) COLLECT (SELECTQ S ((AFTER >) '>) ((BEFORE <) '<) ((SAME SAMEDATE =) '=) (AUTHOR 'AUTHOR) (-* '-*) (*- '*-) (ERROR "UNRECOGNIZED SELECT PARAMETER" S] (PROG (INFOS1 INFOS2 CANDIDATES SELECTED COMPAREDATE DEPTH1 DEPTH2) [SETQ COMPAREDATE (INTERSECTION SELECT '(< > =] (* ;; "DIRECTORYNAME here to get unrelativized specifications for header.") (* ;; "Allow all subdirectories if a directory ends in *, but peel it off for the resolution") (CL:WHEN (EQ '* (NTHCHAR DIR1 -1)) (SETQ DEPTH1 T) (SETQ DIR1 (SUBSTRING DIR1 1 -2))) (CL:WHEN (EQ '* (NTHCHAR DIR2 -1)) (SETQ DEPTH2 T) (SETQ DIR2 (SUBSTRING DIR2 1 -2))) (SETQ DIR1 (OR (DIRECTORYNAME (OR DIR1 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR1))) (SETQ DIR2 (OR (DIRECTORYNAME (OR DIR2 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR2))) (PRINTOUT T "Comparing " DIR1 6 "vs. " DIR2 T "as of " (DATE) " selecting " SELECT " ... ") (SETQ INFOS1 (COMPAREDIRECTORIES.INFOS (CDFILES DIR1 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH1) USEDIRECTORYDATE)) (SETQ INFOS2 (COMPAREDIRECTORIES.INFOS (CDFILES DIR2 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH2) USEDIRECTORYDATE)) (CL:UNLESS (AND INFOS2 INFOS1) (RETURN)) (* ;; "At this point the CAR of each info is the atomic match-name. Peel it off to produce candidate entries.") (* ;;  "Look through all of the I2's because multiple versions (if VERSIONS) have the same matchname") [SETQ CANDIDATES (FOR I1 IN INFOS1 JOIN (IF ALLVERSIONS THEN (OR (FOR I2 IN INFOS2 WHEN (EQ (CAR I2) (CAR I1)) COLLECT (LIST (CAR I1) (CDR I1) (CDR I2))) (CONS (LIST (CAR I1) (CDR I1) NIL))) ELSE (CONS (LIST (CAR I1) (CDR I1) (CDR (ASSOC (CAR I1) INFOS2] (* ;; "Could be some 2's without 1's") (SORT [NCONC CANDIDATES (FOR I2 IN INFOS2 UNLESS (ASSOC (CAR I2) CANDIDATES) COLLECT (LIST (CAR I2) NIL (CDR I2] T) (* ;; "CANDIDATES is now a sorted list of the form (matchname entry1 entry2) where an entry consists of (fullname date length author)") (* ;; "Do the SELECT filtering and insert the date relation.") [SETQ SELECTED (FOR C MATCHNAME INFO1 INFO2 IDATE1 IDATE2 DATEREL BINCOMP IN CANDIDATES EACHTIME (SETQ MATCHNAME (POP C)) (SETQ INFO1 (POP C)) (SETQ INFO2 (POP C)) (IF (AND INFO1 INFO2) THEN (SETQ IDATE1 (IDATE (FETCH DATE OF INFO1))) (SETQ IDATE2 (IDATE (FETCH DATE OF INFO2))) (SETQ DATEREL (IF (IGREATERP IDATE1 IDATE2) THEN '> ELSEIF (ILESSP IDATE1 IDATE2) THEN '< ELSE '=)) ELSE (* ;; "Just for printing--no comparison") (SETQ DATEREL '*)) WHEN (IF (AND INFO1 INFO2) THEN (OR (NULL COMPAREDATE) (SELECTQ DATEREL (> (MEMB '> SELECT)) (< (MEMB '< SELECT)) (= (MEMB '= SELECT)) (SHOULDNT))) ELSEIF INFO1 THEN (* ;; "OK if INFO2 is missing?") (MEMB '*- SELECT) ELSE (* ;; "OK if INFO1 is missing?") (MEMB '-* SELECT)) COLLECT (CREATE CDENTRY MATCHNAME _ MATCHNAME INFO1 _ INFO1 DATEREL _ DATEREL INFO2 _ INFO2 EQUIV _ (CL:UNLESS (EQ DATEREL '*) (BINCOMP (FETCH FULLNAME OF INFO1) (FETCH FULLNAME OF INFO2) T (FETCH EOL OF INFO1) (FETCH EOL OF INFO2)))] (PRINTOUT T (LENGTH SELECTED) " entries" T) (PUSH SELECTED (LIST DIR1 DIR2 SELECT (DATE))) (SETQ LASTCDENTRIES SELECTED) (CL:UNLESS OUTPUTFILE (RETURN SELECTED)) (RETURN (CDPRINT SELECTED OUTPUTFILE (MEMB 'AUTHOR SELECT SELECT]) (CDFILES [LAMBDA (DIR FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH) (* ; "Edited 14-Oct-2020 21:17 by rmk:") (* ;; "Returns a list of fullnames for files that satisfy the criteria") (* ;; "For each name returned by (DIRECTORY DIR), assumes that FILEPATTERNS applies to the suffix after the directory (i.e. after NAMEPOS). That includes possibly subdirectories, dotted files in ultimate file names, and versions.") (* ;; " Exclude subdirectories unless FILEPATTERNS includes *>*") (* ;; " Exclude dotted files (.xxx) unless FILEPATTERNS includes .*") (* ;; " Exclude files with extensions in EXTENSIONSTOAVOID (*=NIL does no filtering)") (* ;; " Exclude older versions unless ALLVERSIONS=T") (* ;; " DEPTH is the number of subdirectories below the ones specified in DIR (NIL top-level of DIR only, T = any depth)") (* ;; "Resolve relative directories, so we can suppress subdirectory matches. ") (SETQ EXTENSIONSTOAVOID (MKLIST (U-CASE EXTENSIONSTOAVOID))) [SETQ FILEPATTERNS (MKLIST (OR FILEPATTERNS '*] (FOR FP FN FPNAME FPEXT EXCLUDEDOTTED (TOPDIR _ (DIRECTORYNAME (OR DIR T))) IN FILEPATTERNS JOIN [SETQ FPNAME (U-CASE (FILENAMEFIELD FP 'NAME] [SETQ FPEXT (U-CASE (FILENAMEFIELD FP 'EXTENSION] (CL:UNLESS FPNAME (IF FPEXT THEN (* ;; ".XY") (SETQ FPNAME (PACK* "." FPEXT)) (SETQ FPEXT NIL) ELSE (SETQ FPNAME '*) (SETQ FPEXT '*))) (SETQ EXCLUDEDOTTED (NEQ (CHARCODE %.) (CHCON1 FPNAME))) (SETQ FN (PACKFILENAME.STRING 'VERSION (CL:IF ALLVERSIONS '* "") 'DIRECTORY TOPDIR 'NAME '* 'EXTENSION '*)) (* ;; "DEPTH is the number of internal %">%"") [IF (EQ DEPTH T) THEN (SETQ DEPTH MAX.SMALLP) ELSEIF DEPTH ELSE (SETQ DEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FN 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT] (FOR FULLNAME NAME EXT THISDEPTH IN (DIRECTORY FN) EACHTIME [SETQ NAME (U-CASE (FILENAMEFIELD FULLNAME 'NAME] [SETQ EXT (U-CASE (FILENAMEFIELD FULLNAME 'EXTENSION] (CL:UNLESS NAME (IF EXT THEN (* ;; ".XY") (SETQ NAME (PACK* "." EXT)) (SETQ EXT NIL))) (CL:WHEN (AND EXCLUDEDOTTED (EQ (CHARCODE %.) (CHCON1 NAME))) (GO $$ITERATE)) (SETQ THISDEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FULLNAME 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT))) (* ;; "An empty subdirectory may appear without name or extensions") WHEN (AND (OR NAME EXT) (OR (EQ FPNAME '*) (EQ FPNAME NAME)) (OR (EQ FPEXT '*) (EQ FPEXT EXT))) UNLESS [OR (IGREATERP THISDEPTH DEPTH) (AND EXT (OR (MEMB '* EXTENSIONSTOAVOID) (MEMB EXT EXTENSIONSTOAVOID] COLLECT FULLNAME) FINALLY (CL:UNLESS $$VAL (PRINTOUT T "No relevant files in " TOPDIR T]) (COMPAREDIRECTORIES.INFOS [LAMBDA (FILES USEDIRECTORYDATE) (* ; "Edited 13-Oct-2020 08:42 by rmk:") (* ;; "Value is a list of CDINFOS with the match-name consed on to the front") (FOR FULLNAME TYPE LDATE IN FILES COLLECT (* ;; "GDATE/IDATE in case Y2K") (SETQ LDATE (FILEDATE FULLNAME)) (* ; "Is it a Lisp file?") (CONS (MATCHNAME FULLNAME) (CREATE CDINFO FULLNAME _ FULLNAME DATE _ [GDATE (IDATE (IF USEDIRECTORYDATE THEN (GETFILEINFO FULLNAME 'CREATIONDATE) ELSEIF (OR LDATE (GETFILEINFO FULLNAME 'CREATIONDATE] LENGTH _ (GETFILEINFO FULLNAME 'LENGTH) AUTHOR _ (GETFILEINFO FULLNAME 'AUTHOR) TYPE _ (IF LDATE THEN (CL:IF (MEMB (FILENAMEFIELD FULLNAME 'EXTENSION) *COMPILED-EXTENSIONS*) 'COMPILED 'SOURCE) ELSE (PRINTFILETYPE FULLNAME)) EOL _ (EOLTYPE FULLNAME]) (MATCHNAME [LAMBDA (NAME) (* ; "Edited 5-Sep-2020 13:41 by rmk:") (* ;; "The NAME.DIR for matching related files") (LET ((M (PACKFILENAME 'HOST NIL 'VERSION NIL 'DIRECTORY NIL 'BODY NAME))) (* ;; "Strip off the nuisance period") (CL:IF (EQ (CHARCODE %.) (NTHCHARCODE M -1)) (SUBATOM M 1 -2) M)]) ) (DEFINEQ (CDPRINT [LAMBDA (CDENTRIES FILE PRINTAUTHOR) (* ; "Edited 13-Oct-2020 08:38 by rmk:") (* ;; "Typically CDENTRIES will have a header. If not, we fake one up, at least for the directories and today's date.") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (RESETLST (LET (INFO1 TEXT STREAM DATE1POS ENDDATE1 DIR1 DIR2 (HEADER (CAR CDENTRIES)) NCHARSDIR1) (CL:UNLESS (STRINGP (CADR HEADER)) (SETQ HEADER (LIST [FOR E IN CDENTRIES WHEN (FETCH INFO1 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO1 OF E] [FOR E IN CDENTRIES WHEN (FETCH INFO2 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO2 OF E] NIL (DATE))) (PUSH CDENTRIES HEADER)) (SETQ DIR1 (CAR HEADER)) (SETQ NCHARSDIR1 (NCHARS DIR1)) (SETQ DIR2 (CADR HEADER)) (CL:UNLESS (SETQ STREAM (GETSTREAM FILE 'OUTPUT T)) [RESETSAVE (SETQ STREAM (OPENSTREAM (PACKFILENAME 'EXTENSION 'TXT 'BODY FILE) 'OUTPUT 'NEW)) '(PROGN (CLOSEF? OLDVALUE]) (CL:WHEN DIR1 (PRINTOUT STREAM "Comparing " DIR1 6 "vs. " DIR2 T "as of " (CADDDR HEADER)) (CL:WHEN (CADDR HEADER) (PRINTOUT STREAM " selecting " (CADDR HEADER))) (PRINTOUT STREAM -2 (LENGTH (CDR CDENTRIES)) " entries" T T)) (LINELENGTH 1000 STREAM) (* ; "Don't wrap") (* ;; "DATE1POS is the position of the first character of INFO1's date, used for tabbing. We have to measure the filename, date, size, and author if desired") (IF (CDR CDENTRIES) THEN (FOR E INFO1 (MAXDATE1WIDTH _ 0) (SPACEWIDTH _ 1) (PARENWIDTH _ 2) IN (CDR CDENTRIES) WHEN (SETQ INFO1 (FETCH INFO1 OF E)) LARGEST [SETQ MAXDATE1WIDTH (IMAX MAXDATE1WIDTH (NCHARS (FETCH DATE OF INFO1] (IPLUS (- (NCHARS (FETCH FULLNAME OF INFO1)) NCHARSDIR1) (NCHARS (FETCH LENGTH OF INFO1)) (CL:IF PRINTAUTHOR (IPLUS SPACEWIDTH PARENWIDTH (NCHARS (FETCH AUTHOR OF INFO1))) 0)) FINALLY (* ;;  "First 4 for width of equiv. $$EXTREME is NIL if there are no INFO1's") (SETQ DATE1POS (IPLUS (OR $$EXTREME 10) 4 (ITIMES 3 SPACEWIDTH))) (SETQ ENDDATE1 (IPLUS DATE1POS MAXDATE1WIDTH) )) (FOR E IN (CDR CDENTRIES) DO (CDPRINT.LINE STREAM E PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 (NCHARS DIR2))) ELSE (PRINTOUT T "CDENTRIES is empty" T)) (AND STREAM (CLOSEF? STREAM))))]) (CDPRINT.LINE [LAMBDA (STREAM ENTRY PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 NCHARSDIR2) (* ; "Edited 13-Oct-2020 08:51 by rmk:") (* ;; "Format one line of the directory comparison listing. If PRINTAUTHOR and AUTHOR1 or AUTHOR2 are non-NIL, list the author in parens; otherwise omit it.") (LET ((INFO1 (FETCH INFO1 OF ENTRY)) (INFO2 (FETCH INFO2 OF ENTRY))) (PRINTOUT STREAM (SELECTQ (FETCH EQUIV OF ENTRY) (T "==") (NIL " ") (PROGN (SELECTQ (FETCH EOL OF INFO1) (CR 'C) (LF 'L) (CRLF 2) " ") (SELECTQ (FETCH EOL OF INFO2) (CR 'C) (LF 'L) (CRLF 2) " "))) " ") (CL:WHEN INFO1 (PRINTOUT STREAM (SUBSTRING (FETCH FULLNAME OF INFO1) (ADD1 NCHARSDIR1) NIL (CONSTANT (CONCAT))) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO1) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO1) .TAB0 DATE1POS (FETCH DATE OF INFO1))) (PRINTOUT STREAM .TAB0 ENDDATE1 " " (FETCH DATEREL OF ENTRY) " ") (CL:WHEN INFO2 (PRINTOUT STREAM (FETCH DATE OF INFO2) " " (SUBSTRING (FETCH FULLNAME OF INFO2) (ADD1 NCHARSDIR2) NIL (CONSTANT (CONCAT))) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO2) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO2))) (TERPRI STREAM]) ) (DEFINEQ (CDMAP [LAMBDA (CDENTRIES FN) (* ; "Edited 6-Sep-2020 15:58 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) DO (APPLY* FN CDE]) (CDENTRY [LAMBDA (MATCHNAME CDENTRIES) (* ; "Edited 5-Sep-2020 21:09 by rmk:") (ASSOC MATCHNAME (OR CDENTRIES LASTCDENTRIES]) (CDSUBSET [LAMBDA (CDENTRIES FN) (* ; "Edited 15-Sep-2020 13:49 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (CONS (CAR CDENTRIES) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) WHEN (APPLY* FN CDE) COLLECT CDE]) ) (DEFINEQ (BINCOMP [LAMBDA (FILE1 FILE2 EOLDIFFOK EOL1 EOL2) (* ; "Edited 13-Oct-2020 08:53 by rmk:") (* ;; "Returns T if FILE1 and FILE2 are byte-equivalent. Returns EOLDIFF if they are byte equivalent except for CR/LF/CRLF exchanges. ") (* ;; "If EOLDIFFOK, return indicates that the files are the same except for EOL mappings. If EOL1 and EOL2 are not provided, they are computed here.") (IF (IEQP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) THEN [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (* ;; "Simpler code to recompute eol's even if provided") (BIND B1 B2 EOL1 EOL2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS (AND EOLDIFFOK (SELCHARQ B1 (CR (CL:WHEN (EQ EOL1 'LF) (RETURN NIL)) (SETQ EOL1 'CR) (SETQ EOL2 'LF) (EQ B2 (CHARCODE LF))) (LF (CL:WHEN (EQ EOL1 'CR) (RETURN NIL)) (SETQ EOL1 'LF) (SETQ EOL2 'CR) (EQ B2 (CHARCODE CR))) NIL)) (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T] ELSEIF EOLDIFFOK THEN (* ;; "Lengths are different possibly because of CRLF to CR/LF substitutions.") (* ;;  "More complex code could detect the EOLTYPE incrementally without separate passes, but ...") (CL:UNLESS EOL1 (SETQ EOL1 (EOLTYPE FILE1))) (CL:UNLESS EOL2 (SETQ EOL2 (EOLTYPE FILE2))) (CL:WHEN (IF [AND (EQ EOL1 'CRLF) (MEMB EOL2 '(LF CR] ELSEIF [AND (EQ EOL2 'CRLF) (MEMB EOL1 '(LF CR] THEN (SWAP FILE1 FILE2)) (* ;; "FILE1 is now CRLF, FILE2 is not. If FILE1 isn't longer, it can't have a CRLF that corresponds to a CR or LF.") (CL:WHEN (IGREATERP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND B1 B2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS [AND (EQ (CHARCODE CR) B1) (EQ (CHARCODE LF) (\BIN STREAM1)) (MEMB B2 (CHARCODE (CR LF] (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T]))]) (EOLTYPE [LAMBDA (FILE) (* ; "Edited 3-Sep-2020 17:05 by rmk:") (* ;; "Returns the EOLCONVENTION of FILE if it only sees one kind, NIL if it can't decide.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (SETFILEINFO STREAM 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND EOLTYPE DO (SELCHARQ (OR (\BIN STREAM) (RETURN EOLTYPE)) (CR (IF (EQ (CHARCODE LF) (\PEEKBIN STREAM T)) THEN (CL:WHEN (MEMB EOLTYPE '(LF CR)) (RETURN NIL)) (\BIN STREAM) (SETQ EOLTYPE 'CRLF) ELSEIF (MEMB EOLTYPE '(LF CRLF)) THEN (RETURN NIL) ELSE (SETQ EOLTYPE 'CR))) (LF (CL:WHEN (MEMB EOLTYPE '(CR CRLF)) (RETURN NIL)) (SETQ EOLTYPE 'LF)) NIL]) ) (DECLARE%: EVAL@COMPILE (RECORD CDENTRY (MATCHNAME INFO1 DATEREL INFO2 . EQUIV)) (RECORD CDINFO (FULLNAME DATE LENGTH AUTHOR TYPE EOL)) ) (* ;; "look for compiled files older than the sources") (DEFINEQ (FIND-UNCOMPILED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 20-Sep-2020 23:04 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;; "Produces a list of the source files in FILES that have no corresponding compiled file") (* ;; "This determines whether there is at least one compiled file. If there are two or more, that's a problem") (* ;; "We want the most recent version only") (* ;; "Source files have a 2-element created-as with a non-NIL date") (SETQ FILES (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) UNLESS (MEMB (SETQ F (PACKFILENAME 'VERSION NIL 'BODY F)) $$VAL) COLLECT F)) (FOR F SCREATION FILES IN FILES WHEN (AND (CADR (SETQ SCREATION (CREATED-AS F))) (NOT (CDDR SCREATION))) WHEN [SETQ FILES (FOR CEXT CF IN (OR COMPILEEXTS *COMPILED-EXTENSIONS*) WHEN (SETQ CF (INFILEP (PACKFILENAME 'EXTENSION CEXT 'VERSION NIL 'BODY F))) COLLECT (CL:WHEN (SOURCE-FOR-COMPILED-P SCREATION CF DFASLMARGIN) (RETURN NIL)) CF FINALLY (* ;; "If we found some compiled files, they weren't on this source. If there weren't any compiled files to check, maybe there weren't any functions.") (* ;;  "NLSETQ because we don't want to stop if there is an error, typically from a package problem") (RETURN (OR $$VAL (LET [(FCOMS (CAR (NLSETQ (GETDEF (FILECOMS F) 'VARS F] (IF (NULL FCOMS) THEN (* ;;  "GETDEF caused an error. Maybe a package problem. ") (AND NIL 'NOCOMMANDS) ELSEIF (INFILECOMS? NIL '(FUNCTIONS FNS) FCOMS) THEN T] COLLECT (CONS F (SELECTQ FILES (T NIL) (NOCOMMANDS (CONS "No commands")) (FOR CF IN FILES COLLECT (* ;;  "Positive means that compiled is later than source, normal order but maybe by too much.") (* ;;  "Negative means that compiled came before source. Odd") (LIST CF (COMPILE-SOURCE-DATE-DIFF CF SCREATION]) (FIND-UNSOURCED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 15-Sep-2020 15:32 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;;  "Produces a list of compiled FILES for which no source file can be found in the same directory.") (* ;; "The source date in at least one DFASL was off by a second, maybe some sort of IDATE rounding? So, give a margin.") (* ;; "We want the most recent version only. Check CREATED-AS to make sure it really is a compiled file.") (* ;; "Sort to get lcoms and dfasls next to each other.") (LET (CCREATEDS) (SETQ CCREATEDS (FOR CEXT FOUND CCREATED INSIDE (OR COMPILEEXTS *COMPILED-EXTENSIONS*) JOIN (FOR CF IN [OR (LISTP FILES) (FILDIR (PACKFILENAME 'EXTENSION CEXT 'VERSION "" 'BODY '*] WHEN (CDDR (SETQ CCREATED (CREATED-AS CF))) UNLESS (MEMBER CCREATED $$VAL) COLLECT CCREATED))) (* ;; "CCREATEDS is now a list of CREATED-AS items") (FOR CC SF IN CCREATEDS UNLESS (AND [SETQ SF (INFILEP (PACKFILENAME 'EXTENSION NIL 'VERSION NIL 'BODY (CAR CC] (SOURCE-FOR-COMPILED-P (SETQ SF (CREATED-AS SF)) CC DFASLMARGIN)) COLLECT [LIST (CAR CC) (AND SF (LIST (CAR SF) (ROUND (COMPILE-SOURCE-DATE-DIFF CC SF] FINALLY (RETURN (SORT $$VAL (FUNCTION (LAMBDA (CF1 CF2) (ALPHORDER (FILENAMEFIELD (CAR CF1) 'NAME) (FILENAMEFIELD (CAR CF2) 'NAME]) (FIND-SOURCE-FILES [LAMBDA (CFILES SDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (CFILE . SFILES) pairs where CFILE is a Lisp compiled file in CFILES SFILES is a list of source files in SDIRS that CFILE was compiled on.") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ SDIRS (FOR SD INSIDE (OR SDIRS T) COLLECT (DIRECTORYNAME SD))) (SORT (FOR CF SFILES CNAME CCREATED IN (OR (LISTP CFILES) (FILDIR CFILES)) WHEN (AND (SETQ CNAME (INFILEP CF)) (CDDR (SETQ CCREATED (CREATED-AS CF))) (SETQ SFILES (FOR SD SF IN SDIRS WHEN (AND (SETQ SF (INFILEP (PACKFILENAME 'NAME (FILENAMEFIELD CF 'NAME) 'BODY SD))) (SOURCE-FOR-COMPILED-P SF CCREATED DFASLMARGIN)) COLLECT SF))) COLLECT (CONS CNAME SFILES)) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-COMPILED-FILES [LAMBDA (SFILES CDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (SFILE . CFILES) pairs where SFILE is a Lisp source file in SFILES CFILES is a list of compiled files in CDIRS that were compiled on SFILE.") (* ;; "FILEDATE is true for source files and compiled files") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ CDIRS (FOR CD INSIDE (OR CDIRS T) COLLECT (DIRECTORYNAME CD))) (SORT (FOR SF CFILES SNAME SCREATED IN (OR (LISTP SFILES) (FILDIR SFILES)) WHEN [AND (SETQ SNAME (INFILEP SF)) (SETQ SCREATED (CREATED-AS SF)) (NOT (CDDR SCREATED)) (SETQ CFILES (FOR CEXT (ROOT _ (FILENAMEFIELD SNAME 'NAME)) IN *COMPILED-EXTENSIONS* JOIN (FOR CD CF IN CDIRS WHEN (AND (SETQ CF (INFILEP (PACKFILENAME 'NAME ROOT 'EXTENSION CEXT 'BODY CD))) (SOURCE-FOR-COMPILED-P SCREATED CF DFASLMARGIN)) COLLECT CF] COLLECT (CONS SNAME CFILES )) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-UNLOADED-FILES [LAMBDA (FILES) (* ; "Edited 9-Sep-2020 19:35 by rmk:") (* ;; "Returns the files in FILES that don't have FILECREATED properties and presumably are therefore not loaded in the current sysout.") (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (AND (SETQ F (INFILEP (CL:IF (LISTP F) (CAR F) F))) (FILEDATE F)) UNLESS (GETP (FILENAMEFIELD F 'NAME) 'FILEDATES) COLLECT F]) (FIND-LOADED-FILES [LAMBDA (ROOTFILENAMES) (* ; "Edited 19-Sep-2020 07:20 by rmk:") (FOR RN INSIDE ROOTFILENAMES WHEN (GETP RN 'FILEDATES) COLLECT (CONS RN (FOR F IN LOADEDFILELST WHEN (EQ RN (FILENAMEFIELD F 'NAME)) COLLECT F]) (FIND-MULTICOMPILED-FILES [LAMBDA (FILES SHOWINFO) (* ; "Edited 20-Sep-2020 20:57 by rmk:") (* ;; "Returns a list of names for files in FILES that have multiple compilations") (LET (SFILES) (FOR F EXT NAME IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (MEMB (SETQ EXT (FILENAMEFIELD F 'EXTENSION)) *COMPILED-EXTENSIONS*) DO (SETQ NAME (FILENAMEFIELD F 'NAME)) (* ;; "PUSHNEW because we haven't filtered out versions") (PUSHNEW [CDR (OR (ASSOC NAME SFILES) (CAR (PUSH SFILES (CONS NAME] EXT)) (FOR S IN SFILES WHEN (CDDR S) COLLECT (IF SHOWINFO THEN `[,(CAR S) ,(CADAR (FIND-LOADED-FILES (CAR S))) ,(CREATED-AS (CAR S)) ,@(FOR EXT IN (SORT (CDR S)) COLLECT (CREATED-AS (PACKFILENAME 'EXTENSION EXT 'BODY (CAR S] ELSE (CAR S]) ) (DEFINEQ (CREATED-AS [LAMBDA (FILE) (* ; "Edited 20-Sep-2020 23:06 by rmk:") (* ;; "For lisp source files, returns (filecreatename filecreateddate)") (* ;; "For lisp compiled files, returns (cfilename cfiledate sfilecreatename sfilecreateddate)") (* ;; "For other files, (fullfilename NIL)") (* ;; "The cfilename is just the current directory name for DFASLs.") (* ;; "So: (CADR value) is non-NIL for Lisp files. Of those, (CDDR value) is non-NIL for compiled files.") (* ;; "We disable the package delimiter because the atoms in changes may have a packages that we don't know.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (LET (FILEDATE FILENAME SOURCEDATE SOURCENAME LINE POS) [IF (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) THEN (* ; "Managed source or LCOM") (RESETLST [LET (FORM SFORM (RDTBL (FIND-READTABLE "OLD-INTERLISP-FILE"))) (SETQ POS (GETFILEPTR STREAM)) (READCCODE STREAM) (IF (EQ 'DEFINE-FILE-INFO (RATOM STREAM RDTBL)) THEN (* ;; "Reading is package-safe") (SETFILEPTR STREAM POS) (SETQ FORM (READ STREAM RDTBL)) (SETQ RDTBL (FIND-READTABLE (LISTGET (CDR FORM) :READTABLE))) ELSE (SETFILEPTR STREAM POS)) (CL:WHEN (EQ 'PACKAGEDELIM (GETSYNTAX '%: RDTBL)) [RESETSAVE (SETSYNTAX '%: 'OTHER RDTBL) `(SETSYNTAX %: PACKAGEDELIM ,RDTBL]) (* ;; "One way or the other, we're ready for the filecreated") (CL:WHEN (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (SETQ FORM (READ STREAM RDTBL)) (CL:WHEN (MEMB (U-CASE (CAR FORM)) '(FILECREATED IL%:FILECREATED)) (* ;; "IL%%:FILECREATED because we screwed the readtable.") (IF [STREQUAL "compiled on " (CAR (LISTP (CADDR FORM] THEN (* ; "LCOM, get source info") (IF [AND (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (MEMB [U-CASE (CAR (SETQ SFORM (READ STREAM RDTBL] '(FILECREATED IL%:FILECREATED] THEN (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM)) (SETQ SOURCENAME (CADDR SFORM)) (SETQ SOURCEDATE (CADR SFORM)) ELSE (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM))) ELSE (SETQ FILENAME (CADDR FORM)) (SETQ FILEDATE (CADR FORM)))))]) ELSEIF (SETQ POS (STRPOS "XCL Compiler output for source file " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) THEN (* ; "DFASL compiled?") (SETQ SOURCENAME (SUBATOM LINE POS)) (CL:WHEN (SETQ POS (STRPOS "Source file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ SOURCEDATE (GDATE (IDATE (SUBSTRING LINE POS] (CL:WHEN (SETQ POS (STRPOS "FASL file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ FILEDATE (GDATE (IDATE (SUBSTRING LINE POS]))] (* ;; "Revert filenames to Interlisp package if needed:") (CL:WHEN (STRPOS "IL:" FILENAME) (SETQ FILENAME (SUBATOM FILENAME 4))) (CL:WHEN (STRPOS "IL:" SOURCENAME) (SETQ SOURCENAME (MKATOM SOURCENAME 4))) (* ;; "Return DATE NIL if file is not a Lisp file") `(,(OR FILENAME (FULLNAME STREAM)) ,(AND FILEDATE (GDATE (IDATE FILEDATE))) ,@(CL:WHEN SOURCENAME (LIST SOURCENAME (GDATE (IDATE SOURCEDATE))))]) (SOURCE-FOR-COMPILED-P [LAMBDA (SOURCE COMPILED DFASLMARGIN) (* ; "Edited 21-Sep-2020 16:56 by rmk:") (* ;; "There seems to be some variation between the source dates in dfasl files and the filecreated date in the sources, they often don't match exactly. But if they are within DFASLMARGIN, we assume a match. We require exact date match for LCOMS") (* ;; "This is needed for dfasl files created before they recorded the source filecreated name and date instead of the directory source name and date when compile took place.") (* ;; "") (* ;; "DFASLMARGIN is a pair (after before) where we assume a match if the compiled date is no more than after minutes after the source date and no more than before minuts before (the diff is negative then).") (* ;; "A single positive integer x is interpreted as (x 0). A single negative integer x is interpreted as (-x x) (before or after x).") (* ;; "Default is (20 0).") (* ;; "T is positive or negative infinity") (CL:UNLESS (LISTP SOURCE) (SETQ SOURCE (CREATED-AS SOURCE))) (CL:UNLESS (LISTP COMPILED) (SETQ COMPILED (CREATED-AS COMPILED))) (SETQ DFASLMARGIN (IF (NULL DFASLMARGIN) THEN (* ;;  "If compiled is later than source by less than 20 minutes, it's probably OK") '(20 0) ELSEIF (LISTP DFASLMARGIN) ELSEIF (IGREATERP DFASLMARGIN 0) THEN (LIST DFASLMARGIN 0) ELSEIF (MINUSP DFASLMARGIN) THEN (LIST (MINUS DFASLMARGIN) DFASLMARGIN))) (OR (EQUAL (CAR SOURCE) (CADDR COMPILED)) (EQUAL (CADR SOURCE) (CADDDR COMPILED)) (AND [EQ 'DFASL (U-CASE (FILENAMEFIELD (CAR COMPILED) 'EXTENSION] (LET ((TIMEDIFF (COMPILE-SOURCE-DATE-DIFF COMPILED SOURCE))) (* ;; "If compiled was no more than 20 minutes later, it's probably OK. Of no more than DFASLMARGIN earlier, if it is negative.") (AND (OR (EQ T (CAR DFASLMARGIN)) (LEQ TIMEDIFF (CAR DFASLMARGIN))) (OR (EQ T (CADR DFASLMARGIN)) (GEQ TIMEDIFF (CADR DFASLMARGIN]) (COMPILE-SOURCE-DATE-DIFF [LAMBDA (CFILE SFILE) (* ; "Edited 20-Sep-2020 22:59 by rmk:") (* ;; "Positive means that compiled is later than source, normal order but maybe by too much. Negative means that compiled came before source, i.e., compiled on a source that didn't yet exist.") (* ;; "Value is in minutes") (ROUND (FQUOTIENT [IDIFFERENCE [IDATE (CADDDR (OR (LISTP CFILE) (CREATED-AS CFILE] (IDATE (CADR (OR (LISTP SFILE) (CREATED-AS SFILE] (TIMES 60 ONESECOND]) ) (DEFINEQ (FIX-DIRECTORY-DATES [LAMBDA (FILES) (* ; "Edited 6-Sep-2020 15:08 by rmk:") (* ;; "For Lisp source and compiled files, ensures that the directory file date corresponds to the filecreated date. Returns the list of files whose dates were changed.") (* ;; "This allows for the fact that directory dates that are no later than, say, 30 seconds of the filecreated date are probably OK--the directory date may be set when the file is closed.") (* ;; "Use IDATEs in case FDCDATE is not Y2K.") (* ;; "Stop if directory date is more than 2 minutes earlier than the filecreated date. Earlier could be because the dates are asserted at different points in the filing process. But 2 minutes is worth thinking about. Returning from HELP will get them aligned.") (FOR F DIDATE FCDATE IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (SETQ FCDATE (FILEDATE F)) UNLESS (IEQP (SETQ DIDATE (GETFILEINFO F 'ICREATIONDATE)) (SETQ FCDATE (IDATE FCDATE))) COLLECT (CL:WHEN (IGREATERP (IDIFFERENCE FCDATE DIDATE) (ITIMES 120 ONESECOND)) (HELP "DIRECTORY DATE EARLIER THAN FILECREATED DATE" (LIST F (GDATE DIDATE) (GDATE FCDATE)))) (SETFILEINFO F 'ICREATIONDATE FCDATE) F]) (FIX-EQUIV-DATES [LAMBDA (CDENTRIES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "For every entry whose files are EQUIVALENT and whose filedates are different, sets the directory of the file with the later date to be the date of the one with the earlier date. This preumes that the later one must have been a copy. ") (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE EARLY LATE IN (CDR CDENTRIES) WHEN (FETCH EQUIV OF CDE) UNLESS (EQ '= (FETCH DATEREL OF CDE)) COLLECT (SELECTQ (FETCH DATEREL OF CDE) (> (SETQ EARLY (FETCH INFO2 OF CDE)) (SETQ LATE (FETCH INFO1 OF CDE))) (< (SETQ EARLY (FETCH INFO1 OF CDE)) (SETQ LATE (FETCH INFO2 OF CDE))) (SHOULDNT)) (SETFILEINFO (FETCH FULLNAME OF LATE) 'ICREATIONDATE (GETFILEINFO (FETCH FULLNAME OF EARLY) 'ICREATIONDATE)) (FETCH FULLNAME OF LATE]) (COPY-COMPARED-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:20 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO MATCHNAME IN (CDR CDENTRIES) EACHTIME (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) WHEN (AND (FETCH FULLNAME OF SINFO) (FETCH FULLNAME OF TINFO)) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'VERSION NIL 'BODY (FETCH FULLNAME OF TINFO))) MATCHNAME]) (COPY-MISSING-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (CL:UNLESS (STRINGP (CADR (CAR CDENTRIES))) (ERROR "(CAR CDENTRIES) IS NOT A VALID PARAMETER LIST" (CAR CDENTRIES))) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO TDIR MATCHNAME (TDIR _ (CL:IF (EQ TARGET 1) (CAAR CDENTRIES) (CADAR CDENTRIES))) IN (CDR CDENTRIES) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) WHEN (AND (FETCH FULLNAME OF SINFO) (NOT (FETCH FULLNAME OF TINFO))) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (* ;; "Using the source fullname in the target should preserve the version number") (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'BODY TDIR 'BODY (FETCH FULLNAME OF SINFO))) MATCHNAME]) (COMPILED-ON-SAME-SOURCE [LAMBDA (CDENTRIES) (* ; "Edited 9-Sep-2020 13:00 by rmk:") (* ;; "Returms a subset of CDENTRIES consisting of files that are compiled on the same source (i.e. their source names or dates are the same). Preserves the header.") (CDSUBSET CDENTRIES (FUNCTION (LAMBDA (CDE) (DECLARE (USEDFREE INFO1 INFO2)) (LET (CREATED1 CREATED2) (CL:WHEN [AND (EQ 'COMPILED (FETCH TYPE OF INFO1)) (EQ 'COMPILED (FETCH TYPE OF INFO2)) [CDDR (SETQ CREATED1 (CREATED-AS (FETCH FULLNAME OF INFO1] (CDDR (SETQ CREATED2 (CREATED-AS (FETCH FULLNAME OF INFO2] (OR (EQUAL (CADDR CREATED1) (CADDR CREATED2)) (EQUAL (CADDDR CREATED1) (CADDDR CREATED2))))]) ) (RPAQ ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"))) (RPAQ? LASTCDENTRIES NIL) (DEFINEQ (COMPARE-ENTRY-SOURCE-FILES [LAMBDA (CDENTRY LISTSTREAM EXAMINE DW?) (* ; "Edited 30-Aug-2020 12:22 by rmk:") (* ;; "Wrapper to call COMPARESOURCES on the Lisp source files of CDENTRY") (CL:WHEN [AND (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO1 OF CDENTRY))) (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO2 OF CDENTRY] (COMPARESOURCES (FETCH FULLNAME OF (FETCH INFO1 OF CDENTRY)) (FETCH FULLNAME OF (FETCH INFO2 OF CDENTRY)) EXAMINE DW? LISTSTREAM))]) ) (FILESLOAD COMPARESOURCES) (PUTPROPS COMPAREDIRECTORIES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1994 1998 2018 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1634 16686 (COMPAREDIRECTORIES 1644 . 10134) (CDFILES 10136 . 14732) ( COMPAREDIRECTORIES.INFOS 14734 . 16249) (MATCHNAME 16251 . 16684)) (16687 23872 (CDPRINT 16697 . 21497 ) (CDPRINT.LINE 21499 . 23870)) (23873 25625 (CDMAP 23883 . 24579) (CDENTRY 24581 . 24749) (CDSUBSET 24751 . 25623)) (25626 31157 (BINCOMP 25636 . 29925) (EOLTYPE 29927 . 31155)) (31370 44577 ( FIND-UNCOMPILED-FILES 31380 . 35023) (FIND-UNSOURCED-FILES 35025 . 37834) (FIND-SOURCE-FILES 37836 . 39540) (FIND-COMPILED-FILES 39542 . 41620) (FIND-UNLOADED-FILES 41622 . 42366) (FIND-LOADED-FILES 42368 . 42922) (FIND-MULTICOMPILED-FILES 42924 . 44575)) (44578 52610 (CREATED-AS 44588 . 49385) ( SOURCE-FOR-COMPILED-P 49387 . 51915) (COMPILE-SOURCE-DATE-DIFF 51917 . 52608)) (52611 61618 ( FIX-DIRECTORY-DATES 52621 . 54617) (FIX-EQUIV-DATES 54619 . 55879) (COPY-COMPARED-FILES 55881 . 58005) (COPY-MISSING-FILES 58007 . 59846) (COMPILED-ON-SAME-SOURCE 59848 . 61616)) (61773 62384 ( COMPARE-ENTRY-SOURCE-FILES 61783 . 62382))))) STOP \ No newline at end of file diff --git a/lispusers/MACINTERFACE b/lispusers/MACINTERFACE index 76123d56..0190e570 100644 --- a/lispusers/MACINTERFACE +++ b/lispusers/MACINTERFACE @@ -1 +1 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "15-Feb-2021 20:50:07"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>MACINTERFACE.;75 21496 changes to%: (FNS MACWINDOW.BUTTONEVENTFN) previous date%: "14-Feb-2021 21:51:47" {DSK}kaplan>Local>medley3.5>git-medley>lispusers>MACINTERFACE.;74) (PRETTYCOMPRINT MACINTERFACECOMS) (RPAQQ MACINTERFACECOMS [ (* ;; "Externals") (COMS (FNS MACWINDOW MACWINDOW.SETUP UNMACWINDOW MACWINDOW.UNSETUP) (INITVARS (MACWINDOWMARGIN 25))) (* ;; "Internals") [COMS (FNS MACWINDOW.BUTTONEVENTFN MACWINDOW.BUTTONEVENTFN.ANYWHERE NEARTOP NEARESTCORNER INCORNER.REGION) (* ;; "Behavior for some known window creators") (FNS MACINT-ADD-EXEC MACINT-SNAPW) (FNS TEDIT.MACINTERFACE TEDIT.SELECTALL) (FNS FB.MAKEHEADINGWINDOW.MACINTERFACE TOTOPW.MACINTERFACE) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (TEDIT.MACINTERFACE) (* ;; "Inspector") (MACWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MACWINDOW.SETUP 'ONEDINSPECT.BUTTONEVENTFN)) (MACWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MACWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MACWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MACWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MACWINDOW.SETUP 'SNAPW 'MACINT-SNAPW) (* ;; "New execs") (MACWINDOW.SETUP 'ADD-EXEC 'MACINT-ADD-EXEC) (* ;; "Existing exec of the load") (MACWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW)) (* ;; "Table browser (specialized to filebrowser)") (MACWINDOW.SETUP 'FB.MAKEHEADINGWINDOW 'FB.MAKEHEADINGWINDOW.MACINTERFACE) (MACWINDOW.SETUP 'TB.BUTTONEVENTFN) (* ;; "Grapher") (MACWINDOW.SETUP 'APPLYTOSELECTEDNODE) (* ;; "Promptwindow") (MACWINDOW PROMPTWINDOW T] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA MACINT-ADD-EXEC]) (* ;; "Externals") (DEFINEQ (MACWINDOW [LAMBDA (WINDOW ANYWHERE) (* ; "Edited 23-Jun-2020 16:01 by rmk:") (* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn.") (CL:UNLESS (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN)) (WINDOWPROP WINDOW 'BUTTONEVENTFN (IF ANYWHERE THEN (FUNCTION MACWINDOW.BUTTONEVENTFN.ANYWHERE) ELSE (FUNCTION MACWINDOW.BUTTONEVENTFN)))) WINDOW]) (MACWINDOW.SETUP [LAMBDA (ORIGFN MACWINDOWFN ANYWHERE) (* ; "Edited 13-Feb-2021 19:53 by rmk:") (* ;; "ORIGFN is either a function that creates windows of a given type (e.g. SNAPW or ADD-EXEC) or the known BUTTONEVENTFN of a class of windows.") (* ;; "Moves ORIGNFN to a new name, prefixed with MACORIG-.") (* ;; "If MACWINDOWFN is given, then that replaces the original definition of ORIGFN, and presumably knows how to call the renamed ORIGFN under the right circumstances. This is typically the case where ORIGFN is a window creator.") (* ;; "Otherwise, ORIGFN is taken to be the BUTTONEVENTFN for a class of windows, and its new definition is defaulted to one that maps left-clicks in appropriate areas into Mac window operations. If not in appropriate areas, then the renamed ORIGNFN is called to give the original button behavior.") (* ;; "If ANYWHERE, moving will happen for any click not in one of the shaping corners.") (* ;; "The renamed function has arguments in addition to WINDOW: the new name for the original function, if MACWINDOFN is provided, and the value specified here for ANYWHERE.") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MACORIG- ORIGFN) PKGNAME)) (MOVD? ORIGFN RENAMEDORIG) (IF MACWINDOWFN THEN (MOVD MACWINDOWFN ORIGFN) ELSE (PUTD ORIGFN `(LAMBDA (WINDOW) (MACWINDOW.BUTTONEVENTFN WINDOW (FUNCTION ,RENAMEDORIG) ,ANYWHERE]) (UNMACWINDOW [LAMBDA (WINDOW) (* ; "Edited 7-Dec-2020 17:57 by rmk:") (* ;; "Restores original window behavior") (CL:WHEN (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) (WINDOWPROP WINDOW 'BUTTONEVENTFN (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN)) (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN NIL)) WINDOW]) (MACWINDOW.UNSETUP [LAMBDA (ORIGFN) (* ; "Edited 6-Jul-2020 13:04 by rmk:") (* ; "Edited 24-Jun-2020 15:09 by rmk:") (* ;; "Moves the renamed original function back to its original name") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MACORIG- ORIGFN) PKGNAME)) (CL:WHEN (GETD RENAMEDORIG) (MOVD RENAMEDORIG ORIGFN]) ) (RPAQ? MACWINDOWMARGIN 25) (* ;; "Internals") (DEFINEQ (MACWINDOW.BUTTONEVENTFN [LAMBDA (WINDOW ORIGFUNCTION ANYWHERE) (* ; "Edited 14-Feb-2021 21:51 by rmk:") (* ; "Edited 24-Jun-2020 20:23 by rmk:") (* ; "Edited 23-May-2020 08:34 by rmk:") (* ; "Edited 10-May-2020 03:35 by rmk:") (* ; "Edited 3-May-2020 21:18 by rmk:") (IF (AND (MOUSESTATE (ONLY LEFT)) (EQ LASTKEYBOARD 0)) THEN (TOTOPW WINDOW) (LET [CORNER TOPMARGIN (MAINREGION (WINDOWPROP WINDOW 'REGION)) (ATTACHEDREGION (WINDOWREGION WINDOW 'SHAPEW] (* ;; "If the window has a TOPMARGIN property, that tells us that it does not have a canonical title but may still have a title-like attached window just above the main window. The TOPMARGIN should be 0 in that case.") (* ;; "This is particularly the case of FILEBROWSER windows, where the the modified ATTACHEDWINDOWTOTOPFN drives the click here. ") (SETQ TOPMARGIN (IF (WINDOWPROP WINDOW 'TOPMARGIN) ELSEIF (WINDOWPROP WINDOW 'TITLE) THEN (FONTPROP WindowTitleDisplayStream 'HEIGHT) ELSE MACWINDOWMARGIN)) (SETQ CORNER (INCORNER.REGION MAINREGION TOPMARGIN)) (IF CORNER THEN (* ;;  "The upper corners may be in the title bar, near the side, so test corners before titlebar.") (* ;; "We are in the corner of the main window, so we are reshaping. But the ghost region should include all of the attached windows, and the starting cursor should be positioned at the corner closest to the selected corner of the main window.") (* ;; "WINDOWREGION includes the attached windows") (LET ((LEFT (FETCH LEFT OF ATTACHEDREGION)) (RIGHT (FETCH RIGHT OF ATTACHEDREGION)) (TOP (FETCH TOP OF ATTACHEDREGION)) (BOTTOM (FETCH BOTTOM OF ATTACHEDREGION)) STARTINGREGION) (* ;; "\CURSORPOSITION moves the mouse to the tracking corner of the ghost region, in screen coordinates, so that the mouse starts out at the tracking corner of the ghost region, even if there are attached windows (as in the filebrowser) that overhang the corner and the initiating click was at the corner of the mainwindow.") (CL:UNLESS (EQ 'DON'T (WINDOWPROP WINDOW 'RESHAPEFN)) [SETQ STARTINGREGION (GETREGION NIL NIL NIL NIL NIL (SELECTQ CORNER (RIGHTBOTTOM (\CURSORPOSITION RIGHT BOTTOM) (GETMOUSESTATE) (LIST LEFT TOP RIGHT BOTTOM)) (LEFTBOTTOM (\CURSORPOSITION LEFT BOTTOM) (GETMOUSESTATE) (LIST RIGHT TOP LEFT BOTTOM)) (RIGHTTOP (\CURSORPOSITION RIGHT TOP) (GETMOUSESTATE) (LIST LEFT BOTTOM RIGHT TOP)) (LEFTTOP (\CURSORPOSITION LEFT TOP) (GETMOUSESTATE) (LIST RIGHT BOTTOM LEFT TOP)) (SHOULDNT]) (SHAPEW WINDOW STARTINGREGION)) T ELSEIF (OR ANYWHERE (NEARTOP MAINREGION TOPMARGIN)) THEN (NEARESTCORNER ATTACHEDREGION) (MOVEW WINDOW) T ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW))) ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW]) (MACWINDOW.BUTTONEVENTFN.ANYWHERE [LAMBDA (WINDOW) (* ; "Edited 3-Dec-2020 14:24 by rmk:") (* ; "Edited 24-Jun-2020 13:24 by rmk:") (* ;; "Move if left-click anywhere, not just titlebar") (MACWINDOW.BUTTONEVENTFN WINDOW NIL T]) (NEARTOP [LAMBDA (MAINREGION TOPMARGIN) (* ; "Edited 12-Feb-2021 23:19 by rmk:") (* ;; "True if the MOUSEY is near the top of MAINREGION. That means in the title bar for titled windows, otherwise a short distance below the top of the window. (Could be in the border?)") (IGREATERP LASTMOUSEY (IDIFFERENCE (FETCH TOP OF MAINREGION) TOPMARGIN]) (NEARESTCORNER [LAMBDA (REGION) (* ; "Edited 14-Feb-2021 21:46 by rmk:") (* ;; "Moves the cursor to the corner of REGION that is closest to the current LASTMOUSEX AND LASTMOUSEY") (\CURSORPOSITION (CL:IF (ILESSP (IDIFFERENCE LASTMOUSEX (FETCH LEFT OF REGION)) (IDIFFERENCE (FETCH RIGHT OF REGION) LASTMOUSEX)) (FETCH LEFT OF REGION) (FETCH RIGHT OF REGION)) (CL:IF (ILESSP (IDIFFERENCE LASTMOUSEY (FETCH BOTTOM OF REGION)) (IDIFFERENCE (FETCH TOP OF REGION) LASTMOUSEY)) (FETCH BOTTOM OF REGION) (FETCH TOP OF REGION))]) (INCORNER.REGION [LAMBDA (MAINREGION TOPMARGIN) (* ; "Edited 12-Feb-2021 23:22 by rmk:") (* ;; "MAINREGION, LASTMOUSEX, LASTMOUSEY in screen coordinates.") (* ;; "TOPMARGIN is the height of the titlebar for titled windows, otherwise the margin at the top of the window's content that we regard as the top. ") (IF (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH LEFT OF MAINREGION))) MACWINDOWMARGIN) THEN (IF (NEARTOP MAINREGION TOPMARGIN) THEN 'LEFTTOP ELSEIF (ILEQ LASTMOUSEY (IPLUS MACWINDOWMARGIN (FETCH BOTTOM OF MAINREGION ))) THEN 'LEFTBOTTOM) ELSEIF (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH RIGHT OF MAINREGION))) MACWINDOWMARGIN) THEN (IF (NEARTOP MAINREGION TOPMARGIN) THEN 'RIGHTTOP ELSEIF (ILEQ LASTMOUSEY (IPLUS MACWINDOWMARGIN (FETCH BOTTOM OF MAINREGION ))) THEN 'RIGHTBOTTOM]) ) (* ;; "Behavior for some known window creators") (DEFINEQ (MACINT-ADD-EXEC [LAMBDA U (* ; "Edited 24-Jun-2020 14:23 by rmk:") (LET [(PROC (APPLY (FUNCTION MACORIG-ADD-EXEC) (FOR N FROM 1 TO U COLLECT (ARG U N] (* ;; "For some reason, the window may not be there immediately") (DISMISS 100) (MACWINDOW (PROCESSPROP PROC 'WINDOW)) PROC]) (MACINT-SNAPW [LAMBDA NIL (* ; "Edited 24-Jun-2020 13:19 by rmk:") (* ;; "No point in shaping a snap window, just move it.;;") (* ;; "This changes the creation function (SNAPW), since snap windows otherwise don't have a BUTTONEVENTN") (LET ((W (MACORIG-SNAPW))) [WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (W) (TOTOPW W) (MOVEW W] W]) ) (DEFINEQ (TEDIT.MACINTERFACE [LAMBDA NIL (* ; "Edited 8-Aug-2020 07:58 by rmk:") (MACWINDOW.SETUP '\TEDIT.BUTTONEVENTFN) (* ;; "All") (TEDIT.SETFUNCTION (CHARCODE "1,a") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,A") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (* ;; "Quit") (TEDIT.SETFUNCTION (CHARCODE "1,q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,Q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE]) (TEDIT.SELECTALL [LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 3-May-2020 17:29 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (CL:WHEN TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch TEXTLEN of (TEXTOBJ TEXTSTREAM))) 'LEFT))]) ) (DEFINEQ (FB.MAKEHEADINGWINDOW.MACINTERFACE [LAMBDA (BROWSERWINDOW WIDTH HEIGHT FONT) (* ; "Edited 13-Feb-2021 23:21 by rmk:") (* ;; "This makes the heading window for a filebrowser, the little black window that has the column headings over the main window. It looks like a titlebar of the main window, our goal here is to make clicking in the heading window behave as if the click had happened in a true title window, so that corners will cause a SHAPE and middle will cause a MOVE. This is achieved by replacing the TOTOPW BUTTONEVENTFN of this window by a function that does the TOTOPW and then invokes the BUTTONEVENTFN of the main window") (* ;; "This function essentially advises the FB.MAKEHEADINGWINDOW in FILEBROWSER--works only if FILEBROWSER was loaded first.") (LET ((HW (MACORIG-FB.MAKEHEADINGWINDOW BROWSERWINDOW WIDTH HEIGHT FONT))) (* ;; "We also mark the height of the attached %"title%" window as the TOPMARGIN of the main window, so that MACWINDOW.BUTTONEVENTFN knows to look outside the putative region.") (WINDOWPROP HW 'BUTTONEVENTFN 'TOTOPW.MACINTERFACE) (WINDOWPROP BROWSERWINDOW 'TOPMARGIN 0) HW]) (TOTOPW.MACINTERFACE [LAMBDA (WINDOW) (* ; "Edited 13-Feb-2021 23:27 by rmk:") (* ;; "This replaces the TOTOPW BUTTONEVENTFN on an attached window where the click is then directed to the MAINWINDOW.") (TOTOPW WINDOW) (LET ((MAIN (MAINWINDOW WINDOW T))) (CL:WHEN MAIN (MACWINDOW.BUTTONEVENTFN MAIN (WINDOWPROP MAIN 'BUTTONEVENTFN)))]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (TEDIT.MACINTERFACE) (* ;; "Inspector") (MACWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MACWINDOW.SETUP  (QUOTE ONEDINSPECT.BUTTONEVENTFN))) (MACWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MACWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MACWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MACWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MACWINDOW.SETUP 'SNAPW 'MACINT-SNAPW) (* ;; "New execs") (MACWINDOW.SETUP 'ADD-EXEC 'MACINT-ADD-EXEC) (* ;; "Existing exec of the load") (MACWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW)) (* ;; "Table browser (specialized to filebrowser)") (MACWINDOW.SETUP 'FB.MAKEHEADINGWINDOW 'FB.MAKEHEADINGWINDOW.MACINTERFACE) (MACWINDOW.SETUP 'TB.BUTTONEVENTFN) (* ;; "Grapher") (MACWINDOW.SETUP 'APPLYTOSELECTEDNODE) (* ;; "Promptwindow") (MACWINDOW PROMPTWINDOW T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MACINT-ADD-EXEC) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (4304 8063 (MACWINDOW 4314 . 4955) (MACWINDOW.SETUP 4957 . 6873) (UNMACWINDOW 6875 . 7254) (MACWINDOW.UNSETUP 7256 . 8061)) (8123 16305 (MACWINDOW.BUTTONEVENTFN 8133 . 13155) ( MACWINDOW.BUTTONEVENTFN.ANYWHERE 13157 . 13522) (NEARTOP 13524 . 13960) (NEARESTCORNER 13962 . 14841) (INCORNER.REGION 14843 . 16303)) (16363 17340 (MACINT-ADD-EXEC 16373 . 16797) (MACINT-SNAPW 16799 . 17338)) (17341 18300 (TEDIT.MACINTERFACE 17351 . 17969) (TEDIT.SELECTALL 17971 . 18298)) (18301 19950 (FB.MAKEHEADINGWINDOW.MACINTERFACE 18311 . 19518) (TOTOPW.MACINTERFACE 19520 . 19948))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "22-Feb-2021 14:01:07"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>MACINTERFACE.;78 20371 changes to%: (VARS MACINTERFACECOMS) previous date%: "22-Feb-2021 12:56:21" {DSK}kaplan>Local>medley3.5>git-medley>lispusers>MACINTERFACE.;77) (PRETTYCOMPRINT MACINTERFACECOMS) (RPAQQ MACINTERFACECOMS [ (* ;; "Externals") (COMS (FNS MACWINDOW MACWINDOW.SETUP UNMACWINDOW MACWINDOW.UNSETUP) (INITVARS (MACWINDOWMARGIN 25))) (* ;; "Internals") [COMS (FNS MACWINDOW.BUTTONEVENTFN MACWINDOW.BUTTONEVENTFN.ANYWHERE NEARTOP NEARESTCORNER INCORNER.REGION) (* ;; "Behavior for some known window creators") (FNS MACINT-ADD-EXEC MACINT-SNAPW) (FNS TEDIT.MACINTERFACE TEDIT.SELECTALL) (FNS TOTOPW.MACINTERFACE) (P (MOVD 'TOTOPW.MACINTERFACE 'TOTOPW.MODERNIZE) (MOVD 'MACWINDOW 'MODERNWINDOW) (MOVD 'UNMACWINDOW 'UNMODERNWINDOW)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (TEDIT.MACINTERFACE) (* ;; "Inspector") (MACWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MACWINDOW.SETUP 'ONEDINSPECT.BUTTONEVENTFN)) (MACWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MACWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MACWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MACWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MACWINDOW.SETUP 'SNAPW 'MACINT-SNAPW) (* ;; "New execs") (MACWINDOW.SETUP 'ADD-EXEC 'MACINT-ADD-EXEC) (* ;; "Existing exec of the load") (MACWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW)) (* ;; "Table browser (for filebrowser)") (MACWINDOW.SETUP 'TB.BUTTONEVENTFN) (* ;; "Grapher") (MACWINDOW.SETUP 'APPLYTOSELECTEDNODE) (* ;; "Promptwindow") (MACWINDOW PROMPTWINDOW T] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA MACINT-ADD-EXEC]) (* ;; "Externals") (DEFINEQ (MACWINDOW [LAMBDA (WINDOW ANYWHERE) (* ; "Edited 23-Jun-2020 16:01 by rmk:") (* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn.") (CL:UNLESS (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN)) (WINDOWPROP WINDOW 'BUTTONEVENTFN (IF ANYWHERE THEN (FUNCTION MACWINDOW.BUTTONEVENTFN.ANYWHERE) ELSE (FUNCTION MACWINDOW.BUTTONEVENTFN)))) WINDOW]) (MACWINDOW.SETUP [LAMBDA (ORIGFN MACWINDOWFN ANYWHERE) (* ; "Edited 13-Feb-2021 19:53 by rmk:") (* ;; "ORIGFN is either a function that creates windows of a given type (e.g. SNAPW or ADD-EXEC) or the known BUTTONEVENTFN of a class of windows.") (* ;; "Moves ORIGNFN to a new name, prefixed with MACORIG-.") (* ;; "If MACWINDOWFN is given, then that replaces the original definition of ORIGFN, and presumably knows how to call the renamed ORIGFN under the right circumstances. This is typically the case where ORIGFN is a window creator.") (* ;; "Otherwise, ORIGFN is taken to be the BUTTONEVENTFN for a class of windows, and its new definition is defaulted to one that maps left-clicks in appropriate areas into Mac window operations. If not in appropriate areas, then the renamed ORIGNFN is called to give the original button behavior.") (* ;; "If ANYWHERE, moving will happen for any click not in one of the shaping corners.") (* ;; "The renamed function has arguments in addition to WINDOW: the new name for the original function, if MACWINDOFN is provided, and the value specified here for ANYWHERE.") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MACORIG- ORIGFN) PKGNAME)) (MOVD? ORIGFN RENAMEDORIG) (IF MACWINDOWFN THEN (MOVD MACWINDOWFN ORIGFN) ELSE (PUTD ORIGFN `(LAMBDA (WINDOW) (MACWINDOW.BUTTONEVENTFN WINDOW (FUNCTION ,RENAMEDORIG) ,ANYWHERE]) (UNMACWINDOW [LAMBDA (WINDOW) (* ; "Edited 7-Dec-2020 17:57 by rmk:") (* ;; "Restores original window behavior") (CL:WHEN (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) (WINDOWPROP WINDOW 'BUTTONEVENTFN (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN)) (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN NIL)) WINDOW]) (MACWINDOW.UNSETUP [LAMBDA (ORIGFN) (* ; "Edited 6-Jul-2020 13:04 by rmk:") (* ; "Edited 24-Jun-2020 15:09 by rmk:") (* ;; "Moves the renamed original function back to its original name") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MACORIG- ORIGFN) PKGNAME)) (CL:WHEN (GETD RENAMEDORIG) (MOVD RENAMEDORIG ORIGFN]) ) (RPAQ? MACWINDOWMARGIN 25) (* ;; "Internals") (DEFINEQ (MACWINDOW.BUTTONEVENTFN [LAMBDA (WINDOW ORIGFUNCTION ANYWHERE) (* ; "Edited 14-Feb-2021 21:51 by rmk:") (* ; "Edited 24-Jun-2020 20:23 by rmk:") (* ; "Edited 23-May-2020 08:34 by rmk:") (* ; "Edited 10-May-2020 03:35 by rmk:") (* ; "Edited 3-May-2020 21:18 by rmk:") (IF (AND (MOUSESTATE (ONLY LEFT)) (EQ LASTKEYBOARD 0)) THEN (TOTOPW WINDOW) (LET [CORNER TOPMARGIN (MAINREGION (WINDOWPROP WINDOW 'REGION)) (ATTACHEDREGION (WINDOWREGION WINDOW 'SHAPEW] (* ;; "If the window has a TOPMARGIN property, that tells us that it does not have a canonical title but may still have a title-like attached window just above the main window. The TOPMARGIN should be 0 in that case.") (* ;; "This is particularly the case of FILEBROWSER windows, where the the modified ATTACHEDWINDOWTOTOPFN drives the click here. ") (SETQ TOPMARGIN (IF (WINDOWPROP WINDOW 'TOPMARGIN) ELSEIF (WINDOWPROP WINDOW 'TITLE) THEN (FONTPROP WindowTitleDisplayStream 'HEIGHT) ELSE MACWINDOWMARGIN)) (SETQ CORNER (INCORNER.REGION MAINREGION TOPMARGIN)) (IF CORNER THEN (* ;;  "The upper corners may be in the title bar, near the side, so test corners before titlebar.") (* ;; "We are in the corner of the main window, so we are reshaping. But the ghost region should include all of the attached windows, and the starting cursor should be positioned at the corner closest to the selected corner of the main window.") (* ;; "WINDOWREGION includes the attached windows") (LET ((LEFT (FETCH LEFT OF ATTACHEDREGION)) (RIGHT (FETCH RIGHT OF ATTACHEDREGION)) (TOP (FETCH TOP OF ATTACHEDREGION)) (BOTTOM (FETCH BOTTOM OF ATTACHEDREGION)) STARTINGREGION) (* ;; "\CURSORPOSITION moves the mouse to the tracking corner of the ghost region, in screen coordinates, so that the mouse starts out at the tracking corner of the ghost region, even if there are attached windows (as in the filebrowser) that overhang the corner and the initiating click was at the corner of the mainwindow.") (CL:UNLESS (EQ 'DON'T (WINDOWPROP WINDOW 'RESHAPEFN)) [SETQ STARTINGREGION (GETREGION NIL NIL NIL NIL NIL (SELECTQ CORNER (RIGHTBOTTOM (\CURSORPOSITION RIGHT BOTTOM) (GETMOUSESTATE) (LIST LEFT TOP RIGHT BOTTOM)) (LEFTBOTTOM (\CURSORPOSITION LEFT BOTTOM) (GETMOUSESTATE) (LIST RIGHT TOP LEFT BOTTOM)) (RIGHTTOP (\CURSORPOSITION RIGHT TOP) (GETMOUSESTATE) (LIST LEFT BOTTOM RIGHT TOP)) (LEFTTOP (\CURSORPOSITION LEFT TOP) (GETMOUSESTATE) (LIST RIGHT BOTTOM LEFT TOP)) (SHOULDNT]) (SHAPEW WINDOW STARTINGREGION)) T ELSEIF (OR ANYWHERE (NEARTOP MAINREGION TOPMARGIN)) THEN (NEARESTCORNER ATTACHEDREGION) (MOVEW WINDOW) T ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW))) ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW]) (MACWINDOW.BUTTONEVENTFN.ANYWHERE [LAMBDA (WINDOW) (* ; "Edited 3-Dec-2020 14:24 by rmk:") (* ; "Edited 24-Jun-2020 13:24 by rmk:") (* ;; "Move if left-click anywhere, not just titlebar") (MACWINDOW.BUTTONEVENTFN WINDOW NIL T]) (NEARTOP [LAMBDA (MAINREGION TOPMARGIN) (* ; "Edited 12-Feb-2021 23:19 by rmk:") (* ;; "True if the MOUSEY is near the top of MAINREGION. That means in the title bar for titled windows, otherwise a short distance below the top of the window. (Could be in the border?)") (IGREATERP LASTMOUSEY (IDIFFERENCE (FETCH TOP OF MAINREGION) TOPMARGIN]) (NEARESTCORNER [LAMBDA (REGION) (* ; "Edited 14-Feb-2021 21:46 by rmk:") (* ;; "Moves the cursor to the corner of REGION that is closest to the current LASTMOUSEX AND LASTMOUSEY") (\CURSORPOSITION (CL:IF (ILESSP (IDIFFERENCE LASTMOUSEX (FETCH LEFT OF REGION)) (IDIFFERENCE (FETCH RIGHT OF REGION) LASTMOUSEX)) (FETCH LEFT OF REGION) (FETCH RIGHT OF REGION)) (CL:IF (ILESSP (IDIFFERENCE LASTMOUSEY (FETCH BOTTOM OF REGION)) (IDIFFERENCE (FETCH TOP OF REGION) LASTMOUSEY)) (FETCH BOTTOM OF REGION) (FETCH TOP OF REGION))]) (INCORNER.REGION [LAMBDA (MAINREGION TOPMARGIN) (* ; "Edited 12-Feb-2021 23:22 by rmk:") (* ;; "MAINREGION, LASTMOUSEX, LASTMOUSEY in screen coordinates.") (* ;; "TOPMARGIN is the height of the titlebar for titled windows, otherwise the margin at the top of the window's content that we regard as the top. ") (IF (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH LEFT OF MAINREGION))) MACWINDOWMARGIN) THEN (IF (NEARTOP MAINREGION TOPMARGIN) THEN 'LEFTTOP ELSEIF (ILEQ LASTMOUSEY (IPLUS MACWINDOWMARGIN (FETCH BOTTOM OF MAINREGION ))) THEN 'LEFTBOTTOM) ELSEIF (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH RIGHT OF MAINREGION))) MACWINDOWMARGIN) THEN (IF (NEARTOP MAINREGION TOPMARGIN) THEN 'RIGHTTOP ELSEIF (ILEQ LASTMOUSEY (IPLUS MACWINDOWMARGIN (FETCH BOTTOM OF MAINREGION ))) THEN 'RIGHTBOTTOM]) ) (* ;; "Behavior for some known window creators") (DEFINEQ (MACINT-ADD-EXEC [LAMBDA U (* ; "Edited 24-Jun-2020 14:23 by rmk:") (LET [(PROC (APPLY (FUNCTION MACORIG-ADD-EXEC) (FOR N FROM 1 TO U COLLECT (ARG U N] (* ;; "For some reason, the window may not be there immediately") (DISMISS 100) (MACWINDOW (PROCESSPROP PROC 'WINDOW)) PROC]) (MACINT-SNAPW [LAMBDA NIL (* ; "Edited 24-Jun-2020 13:19 by rmk:") (* ;; "No point in shaping a snap window, just move it.;;") (* ;; "This changes the creation function (SNAPW), since snap windows otherwise don't have a BUTTONEVENTN") (LET ((W (MACORIG-SNAPW))) [WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (W) (TOTOPW W) (MOVEW W] W]) ) (DEFINEQ (TEDIT.MACINTERFACE [LAMBDA NIL (* ; "Edited 22-Feb-2021 12:56 by rmk:") (CL:WHEN (GETD '\TEDIT.BUTTONEVENTFN) (MACWINDOW.SETUP '\TEDIT.BUTTONEVENTFN) (* ;; "All") (TEDIT.SETFUNCTION (CHARCODE "1,a") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,A") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (* ;; "Quit") (TEDIT.SETFUNCTION (CHARCODE "1,q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,Q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE))]) (TEDIT.SELECTALL [LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 3-May-2020 17:29 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (CL:WHEN TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch TEXTLEN of (TEXTOBJ TEXTSTREAM))) 'LEFT))]) ) (DEFINEQ (TOTOPW.MACINTERFACE [LAMBDA (WINDOW) (* ; "Edited 13-Feb-2021 23:27 by rmk:") (* ;; "This replaces the TOTOPW BUTTONEVENTFN on an attached window where the click is then directed to the MAINWINDOW.") (TOTOPW WINDOW) (LET ((MAIN (MAINWINDOW WINDOW T))) (CL:WHEN MAIN (MACWINDOW.BUTTONEVENTFN MAIN (WINDOWPROP MAIN 'BUTTONEVENTFN)))]) ) (MOVD 'TOTOPW.MACINTERFACE 'TOTOPW.MODERNIZE) (MOVD 'MACWINDOW 'MODERNWINDOW) (MOVD 'UNMACWINDOW 'UNMODERNWINDOW) (DECLARE%: DONTEVAL@LOAD DOCOPY (TEDIT.MACINTERFACE) (* ;; "Inspector") (MACWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MACWINDOW.SETUP  (QUOTE ONEDINSPECT.BUTTONEVENTFN))) (MACWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MACWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MACWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MACWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MACWINDOW.SETUP 'SNAPW 'MACINT-SNAPW) (* ;; "New execs") (MACWINDOW.SETUP 'ADD-EXEC 'MACINT-ADD-EXEC) (* ;; "Existing exec of the load") (MACWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW)) (* ;; "Table browser (for filebrowser)") (MACWINDOW.SETUP 'TB.BUTTONEVENTFN) (* ;; "Grapher") (MACWINDOW.SETUP 'APPLYTOSELECTEDNODE) (* ;; "Promptwindow") (MACWINDOW PROMPTWINDOW T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MACINT-ADD-EXEC) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (4238 7997 (MACWINDOW 4248 . 4889) (MACWINDOW.SETUP 4891 . 6807) (UNMACWINDOW 6809 . 7188) (MACWINDOW.UNSETUP 7190 . 7995)) (8057 16239 (MACWINDOW.BUTTONEVENTFN 8067 . 13089) ( MACWINDOW.BUTTONEVENTFN.ANYWHERE 13091 . 13456) (NEARTOP 13458 . 13894) (NEARESTCORNER 13896 . 14775) (INCORNER.REGION 14777 . 16237)) (16297 17274 (MACINT-ADD-EXEC 16307 . 16731) (MACINT-SNAPW 16733 . 17272)) (17275 18358 (TEDIT.MACINTERFACE 17285 . 18027) (TEDIT.SELECTALL 18029 . 18356)) (18359 18799 (TOTOPW.MACINTERFACE 18369 . 18797))))) STOP diff --git a/lispusers/MACINTERFACE.LCOM.~46~ b/lispusers/MACINTERFACE.LCOM.~46~ deleted file mode 100644 index e1341dda..00000000 Binary files a/lispusers/MACINTERFACE.LCOM.~46~ and /dev/null differ diff --git a/lispusers/MACINTERFACE.~28~ b/lispusers/MACINTERFACE.~28~ deleted file mode 100644 index 2440b53d..00000000 --- a/lispusers/MACINTERFACE.~28~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "18-May-2020 20:12:57"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>MACINTERFACE.;28 8463 changes to%: (FNS MACWINDOW) previous date%: "18-May-2020 17:27:13" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>MACINTERFACE.;27) (PRETTYCOMPRINT MACINTERFACECOMS) (RPAQQ MACINTERFACECOMS [(FNS INTITLEBAR INCORNER MACWINDOW.BUTTONEVENTFN MACWINDOW) (FNS MACINT\TEDIT.BUTTONEVENTFN MACINT\SEDIT-BUTTONEVENTFN MACINT-ADD-EXEC MACINT-DEBUGGER-BUTTON-EVENT MACINT-\ITEM.WINDOW.BUTTON.HANDLER MACINT-SNAPW) (INITVARS (MACINTERFACECORNERMARGIN 25)) (P (MOVD? '\TEDIT.BUTTONEVENTFN 'MACORIG\TEDIT.BUTTONEVENTFN) (MOVD 'MACINT\TEDIT.BUTTONEVENTFN '\TEDIT.BUTTONEVENTFN)) (P (MOVD? 'SEDIT::BUTTONEVENTFN 'MACORIG\SEDIT-BUTTONEVENTFN) (MOVD 'MACINT\SEDIT-BUTTONEVENTFN 'SEDIT::BUTTONEVENTFN)) (P (MOVD? 'ADD-EXEC 'MACORIG-ADD-EXEC) (MOVD 'MACINT-ADD-EXEC 'ADD-EXEC)) (P (MOVD? 'DBG::DEBUGGER-BUTTON-EVENT 'MACORIG-DEBUGGER-BUTTON-EVENT) (MOVD 'MACINT-DEBUGGER-BUTTON-EVENT 'DBG::DEBUGGER-BUTTON-EVENT)) (P (MOVD? '\ITEM.WINDOW.BUTTON.HANDLER 'MACORIG-\ITEM.WINDOW.BUTTON.HANDLER) (MOVD 'MACINT-\ITEM.WINDOW.BUTTON.HANDLER '\ITEM.WINDOW.BUTTON.HANDLER)) (P (MOVD? 'SNAPW 'MACORIG-SNAPW) (MOVD 'MACINT-SNAPW 'SNAPW)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA MACINT-ADD-EXEC]) (DEFINEQ (INTITLEBAR [LAMBDA (WINDOW) (* ; "Edited 3-May-2020 20:38 by rmk:") (IGREATERP (LASTMOUSEY WINDOW) (FETCH TOP OF (DSPCLIPPINGREGION NIL WINDOW]) (INCORNER [LAMBDA (WINDOW MARGIN) (* ; "Edited 13-May-2020 14:26 by rmk:") (* ; "Edited 10-May-2020 12:41 by rmk:") (* ; "Edited 3-May-2020 20:43 by rmk:") (CL:UNLESS MARGIN (SETQ MARGIN MACINTERFACECORNERMARGIN)) (LET ((CR (DSPCLIPPINGREGION NIL WINDOW)) (X (LASTMOUSEX WINDOW)) (Y (LASTMOUSEY WINDOW))) (IF (ILEQ (IABS (IDIFFERENCE X (FETCH LEFT OF CR))) MARGIN) THEN (* ;; "GREATERP puts it in title bar") (IF (IGREATERP Y (FETCH TOP OF CR)) THEN 'LEFTTOP ELSEIF (ILEQ (IABS (IDIFFERENCE Y (FETCH BOTTOM OF CR))) MARGIN) THEN 'LEFTBOTTOM) ELSEIF (ILEQ (IABS (IDIFFERENCE X (FETCH RIGHT OF CR))) MARGIN) THEN (IF (IGREATERP Y (FETCH TOP OF CR)) THEN 'RIGHTTOP ELSEIF (ILEQ (IABS (IDIFFERENCE Y (FETCH BOTTOM OF CR))) MARGIN) THEN 'RIGHTBOTTOM]) (MACWINDOW.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 10-May-2020 03:35 by rmk:") (* ; "Edited 3-May-2020 21:18 by rmk:") (CL:WHEN (MOUSESTATE (ONLY LEFT)) (TOTOPW WINDOW) (LET (REGION (CORNER (INCORNER WINDOW))) (IF CORNER THEN (* ;;  "The upper corners may be in the title bar, near the side, so test this first") (SETQ REGION (WINDOWPROP WINDOW 'REGION)) [LET ((LEFT (FETCH LEFT OF REGION)) (RIGHT (FETCH RIGHT OF REGION)) (TOP (FETCH TOP OF REGION)) (BOTTOM (FETCH BOTTOM OF REGION))) (SHAPEW WINDOW (GETREGION NIL NIL NIL NIL NIL (SELECTQ CORNER (RIGHTBOTTOM (LIST LEFT TOP RIGHT BOTTOM)) (LEFTBOTTOM (LIST RIGHT TOP LEFT BOTTOM)) (RIGHTTOP (LIST LEFT BOTTOM RIGHT TOP)) (LEFTTOP (LIST RIGHT BOTTOM LEFT TOP)) (SHOULDNT] T ELSEIF (INTITLEBAR WINDOW) THEN (MOVEW WINDOW) T)))]) (MACWINDOW [LAMBDA (WINDOW) (* ; "Edited 18-May-2020 20:11 by rmk:") (* ; "Edited 10-May-2020 14:20 by rmk:") (* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn.")  (* ; "Edited 3-May-2020 21:17 by rmk:") (CL:UNLESS (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN)) (WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION MACWINDOW.BUTTONEVENTFN))) WINDOW]) ) (DEFINEQ (MACINT\TEDIT.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 10-May-2020 03:31 by rmk:") (CL:WHEN (LISTP WINDOW) (SETQ WINDOW (CAR WINDOW))) (OR (MACWINDOW.BUTTONEVENTFN WINDOW) (MACORIG\TEDIT.BUTTONEVENTFN WINDOW]) (MACINT\SEDIT-BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 10-May-2020 03:31 by rmk:") (OR (MACWINDOW.BUTTONEVENTFN WINDOW) (MACORIG\SEDIT-BUTTONEVENTFN WINDOW]) (MACINT-ADD-EXEC [LAMBDA U (* ; "Edited 10-May-2020 03:31 by rmk:") (LET [(PROC (APPLY (FUNCTION MACORIG-ADD-EXEC) (FOR N FROM 1 TO U COLLECT (ARG U N] (* ;; "For some reason, the window may not be there immediately") (DISMISS 100) (MACWINDOW (PROCESSPROP PROC 'WINDOW)) PROC]) (MACINT-DEBUGGER-BUTTON-EVENT [LAMBDA (WINDOW) (* ; "Edited 10-May-2020 03:31 by rmk:") (OR (MACWINDOW.BUTTONEVENTFN WINDOW) (MACORIG-DEBUGGER-BUTTON-EVENT WINDOW]) (MACINT-\ITEM.WINDOW.BUTTON.HANDLER [LAMBDA (WINDOW) (* ; "Edited 16-May-2020 22:35 by rmk:") (* ; "Edited 10-May-2020 03:31 by rmk:") (OR (MACWINDOW.BUTTONEVENTFN WINDOW) (MACORIG-\ITEM.WINDOW.BUTTON.HANDLER WINDOW]) (MACINT-SNAPW [LAMBDA NIL (* ; "Edited 18-May-2020 17:20 by rmk:") (LET ((W (MACORIG-SNAPW))) [WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (W) (TOTOPW W) (MOVEW W] W]) ) (RPAQ? MACINTERFACECORNERMARGIN 25) (MOVD? '\TEDIT.BUTTONEVENTFN 'MACORIG\TEDIT.BUTTONEVENTFN) (MOVD 'MACINT\TEDIT.BUTTONEVENTFN '\TEDIT.BUTTONEVENTFN) (MOVD? 'SEDIT::BUTTONEVENTFN 'MACORIG\SEDIT-BUTTONEVENTFN) (MOVD 'MACINT\SEDIT-BUTTONEVENTFN 'SEDIT::BUTTONEVENTFN) (MOVD? 'ADD-EXEC 'MACORIG-ADD-EXEC) (MOVD 'MACINT-ADD-EXEC 'ADD-EXEC) (MOVD? 'DBG::DEBUGGER-BUTTON-EVENT 'MACORIG-DEBUGGER-BUTTON-EVENT) (MOVD 'MACINT-DEBUGGER-BUTTON-EVENT 'DBG::DEBUGGER-BUTTON-EVENT) (MOVD? '\ITEM.WINDOW.BUTTON.HANDLER 'MACORIG-\ITEM.WINDOW.BUTTON.HANDLER) (MOVD 'MACINT-\ITEM.WINDOW.BUTTON.HANDLER '\ITEM.WINDOW.BUTTON.HANDLER) (MOVD? 'SNAPW 'MACORIG-SNAPW) (MOVD 'MACINT-SNAPW 'SNAPW) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MACINT-ADD-EXEC) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (1747 5706 (INTITLEBAR 1757 . 1977) (INCORNER 1979 . 3394) (MACWINDOW.BUTTONEVENTFN 3396 . 5018) (MACWINDOW 5020 . 5704)) (5707 7601 (MACINT\TEDIT.BUTTONEVENTFN 5717 . 6008) ( MACINT\SEDIT-BUTTONEVENTFN 6010 . 6237) (MACINT-ADD-EXEC 6239 . 6663) (MACINT-DEBUGGER-BUTTON-EVENT 6665 . 6896) (MACINT-\ITEM.WINDOW.BUTTON.HANDLER 6898 . 7250) (MACINT-SNAPW 7252 . 7599))))) STOP \ No newline at end of file diff --git a/lispusers/MACINTERFACE.~30~ b/lispusers/MACINTERFACE.~30~ deleted file mode 100644 index 8e3318e0..00000000 --- a/lispusers/MACINTERFACE.~30~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "23-May-2020 08:54:49"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>MACINTERFACE.;30 9079 changes to%: (FNS MACWINDOW.BUTTONEVENTFN MACWINDOW) previous date%: "18-May-2020 17:27:13" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>MACINTERFACE.;27) (PRETTYCOMPRINT MACINTERFACECOMS) (RPAQQ MACINTERFACECOMS [(FNS INTITLEBAR INCORNER MACWINDOW.BUTTONEVENTFN MACWINDOW) (FNS MACINT\TEDIT.BUTTONEVENTFN MACINT\SEDIT-BUTTONEVENTFN MACINT-ADD-EXEC MACINT-DEBUGGER-BUTTON-EVENT MACINT-\ITEM.WINDOW.BUTTON.HANDLER MACINT-SNAPW) (INITVARS (MACINTERFACECORNERMARGIN 25)) (P (MOVD? '\TEDIT.BUTTONEVENTFN 'MACORIG\TEDIT.BUTTONEVENTFN) (MOVD 'MACINT\TEDIT.BUTTONEVENTFN '\TEDIT.BUTTONEVENTFN)) (P (MOVD? 'SEDIT::BUTTONEVENTFN 'MACORIG\SEDIT-BUTTONEVENTFN) (MOVD 'MACINT\SEDIT-BUTTONEVENTFN 'SEDIT::BUTTONEVENTFN)) (P (MOVD? 'ADD-EXEC 'MACORIG-ADD-EXEC) (MOVD 'MACINT-ADD-EXEC 'ADD-EXEC)) (P (MOVD? 'DBG::DEBUGGER-BUTTON-EVENT 'MACORIG-DEBUGGER-BUTTON-EVENT) (MOVD 'MACINT-DEBUGGER-BUTTON-EVENT 'DBG::DEBUGGER-BUTTON-EVENT)) (P (MOVD? '\ITEM.WINDOW.BUTTON.HANDLER 'MACORIG-\ITEM.WINDOW.BUTTON.HANDLER) (MOVD 'MACINT-\ITEM.WINDOW.BUTTON.HANDLER '\ITEM.WINDOW.BUTTON.HANDLER)) (P (MOVD? 'SNAPW 'MACORIG-SNAPW) (MOVD 'MACINT-SNAPW 'SNAPW)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA MACINT-ADD-EXEC]) (DEFINEQ (INTITLEBAR [LAMBDA (WINDOW) (* ; "Edited 3-May-2020 20:38 by rmk:") (IGREATERP (LASTMOUSEY WINDOW) (FETCH TOP OF (DSPCLIPPINGREGION NIL WINDOW]) (INCORNER [LAMBDA (WINDOW MARGIN) (* ; "Edited 13-May-2020 14:26 by rmk:") (* ; "Edited 10-May-2020 12:41 by rmk:") (* ; "Edited 3-May-2020 20:43 by rmk:") (CL:UNLESS MARGIN (SETQ MARGIN MACINTERFACECORNERMARGIN)) (LET ((CR (DSPCLIPPINGREGION NIL WINDOW)) (X (LASTMOUSEX WINDOW)) (Y (LASTMOUSEY WINDOW))) (IF (ILEQ (IABS (IDIFFERENCE X (FETCH LEFT OF CR))) MARGIN) THEN (* ;; "GREATERP puts it in title bar") (IF (IGREATERP Y (FETCH TOP OF CR)) THEN 'LEFTTOP ELSEIF (ILEQ (IABS (IDIFFERENCE Y (FETCH BOTTOM OF CR))) MARGIN) THEN 'LEFTBOTTOM) ELSEIF (ILEQ (IABS (IDIFFERENCE X (FETCH RIGHT OF CR))) MARGIN) THEN (IF (IGREATERP Y (FETCH TOP OF CR)) THEN 'RIGHTTOP ELSEIF (ILEQ (IABS (IDIFFERENCE Y (FETCH BOTTOM OF CR))) MARGIN) THEN 'RIGHTBOTTOM]) (MACWINDOW.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 23-May-2020 08:34 by rmk:") (* ; "Edited 10-May-2020 03:35 by rmk:") (* ; "Edited 3-May-2020 21:18 by rmk:") (IF (MOUSESTATE (ONLY LEFT)) THEN (TOTOPW WINDOW) (LET (REGION (CORNER (INCORNER WINDOW))) (IF CORNER THEN (* ;;  "The upper corners may be in the title bar, near the side, so test this first") (SETQ REGION (WINDOWPROP WINDOW 'REGION)) [LET ((LEFT (FETCH LEFT OF REGION)) (RIGHT (FETCH RIGHT OF REGION)) (TOP (FETCH TOP OF REGION)) (BOTTOM (FETCH BOTTOM OF REGION))) (SHAPEW WINDOW (GETREGION NIL NIL NIL NIL NIL (SELECTQ CORNER (RIGHTBOTTOM (LIST LEFT TOP RIGHT BOTTOM)) (LEFTBOTTOM (LIST RIGHT TOP LEFT BOTTOM)) (RIGHTTOP (LIST LEFT BOTTOM RIGHT TOP)) (LEFTTOP (LIST RIGHT BOTTOM LEFT TOP)) (SHOULDNT] T ELSEIF (INTITLEBAR WINDOW) THEN (MOVEW WINDOW) T ELSEIF (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) THEN (APPLY* (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) WINDOW))) ELSEIF (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) THEN (APPLY* (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) WINDOW]) (MACWINDOW [LAMBDA (WINDOW) (* ; "Edited 18-May-2020 20:11 by rmk:") (* ; "Edited 10-May-2020 14:20 by rmk:") (* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn.")  (* ; "Edited 3-May-2020 21:17 by rmk:") (CL:UNLESS (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN)) (WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION MACWINDOW.BUTTONEVENTFN))) WINDOW]) ) (DEFINEQ (MACINT\TEDIT.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 10-May-2020 03:31 by rmk:") (CL:WHEN (LISTP WINDOW) (SETQ WINDOW (CAR WINDOW))) (OR (MACWINDOW.BUTTONEVENTFN WINDOW) (MACORIG\TEDIT.BUTTONEVENTFN WINDOW]) (MACINT\SEDIT-BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 10-May-2020 03:31 by rmk:") (OR (MACWINDOW.BUTTONEVENTFN WINDOW) (MACORIG\SEDIT-BUTTONEVENTFN WINDOW]) (MACINT-ADD-EXEC [LAMBDA U (* ; "Edited 10-May-2020 03:31 by rmk:") (LET [(PROC (APPLY (FUNCTION MACORIG-ADD-EXEC) (FOR N FROM 1 TO U COLLECT (ARG U N] (* ;; "For some reason, the window may not be there immediately") (DISMISS 100) (MACWINDOW (PROCESSPROP PROC 'WINDOW)) PROC]) (MACINT-DEBUGGER-BUTTON-EVENT [LAMBDA (WINDOW) (* ; "Edited 10-May-2020 03:31 by rmk:") (OR (MACWINDOW.BUTTONEVENTFN WINDOW) (MACORIG-DEBUGGER-BUTTON-EVENT WINDOW]) (MACINT-\ITEM.WINDOW.BUTTON.HANDLER [LAMBDA (WINDOW) (* ; "Edited 16-May-2020 22:35 by rmk:") (* ; "Edited 10-May-2020 03:31 by rmk:") (OR (MACWINDOW.BUTTONEVENTFN WINDOW) (MACORIG-\ITEM.WINDOW.BUTTON.HANDLER WINDOW]) (MACINT-SNAPW [LAMBDA NIL (* ; "Edited 18-May-2020 17:20 by rmk:") (LET ((W (MACORIG-SNAPW))) [WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (W) (TOTOPW W) (MOVEW W] W]) ) (RPAQ? MACINTERFACECORNERMARGIN 25) (MOVD? '\TEDIT.BUTTONEVENTFN 'MACORIG\TEDIT.BUTTONEVENTFN) (MOVD 'MACINT\TEDIT.BUTTONEVENTFN '\TEDIT.BUTTONEVENTFN) (MOVD? 'SEDIT::BUTTONEVENTFN 'MACORIG\SEDIT-BUTTONEVENTFN) (MOVD 'MACINT\SEDIT-BUTTONEVENTFN 'SEDIT::BUTTONEVENTFN) (MOVD? 'ADD-EXEC 'MACORIG-ADD-EXEC) (MOVD 'MACINT-ADD-EXEC 'ADD-EXEC) (MOVD? 'DBG::DEBUGGER-BUTTON-EVENT 'MACORIG-DEBUGGER-BUTTON-EVENT) (MOVD 'MACINT-DEBUGGER-BUTTON-EVENT 'DBG::DEBUGGER-BUTTON-EVENT) (MOVD? '\ITEM.WINDOW.BUTTON.HANDLER 'MACORIG-\ITEM.WINDOW.BUTTON.HANDLER) (MOVD 'MACINT-\ITEM.WINDOW.BUTTON.HANDLER '\ITEM.WINDOW.BUTTON.HANDLER) (MOVD? 'SNAPW 'MACORIG-SNAPW) (MOVD 'MACINT-SNAPW 'SNAPW) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MACINT-ADD-EXEC) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (1771 6322 (INTITLEBAR 1781 . 2001) (INCORNER 2003 . 3418) (MACWINDOW.BUTTONEVENTFN 3420 . 5634) (MACWINDOW 5636 . 6320)) (6323 8217 (MACINT\TEDIT.BUTTONEVENTFN 6333 . 6624) ( MACINT\SEDIT-BUTTONEVENTFN 6626 . 6853) (MACINT-ADD-EXEC 6855 . 7279) (MACINT-DEBUGGER-BUTTON-EVENT 7281 . 7512) (MACINT-\ITEM.WINDOW.BUTTON.HANDLER 7514 . 7866) (MACINT-SNAPW 7868 . 8215))))) STOP \ No newline at end of file diff --git a/lispusers/MACINTERFACE.~31~ b/lispusers/MACINTERFACE.~31~ deleted file mode 100644 index dd681bfe..00000000 --- a/lispusers/MACINTERFACE.~31~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "28-May-2020 18:02:27"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>MACINTERFACE.;31 11583 changes to%: (VARS MACINTERFACECOMS) (FNS MACWINDOW.BUTTONEVENTFN.ANYWHERE MACWINDOW) previous date%: "23-May-2020 08:54:49" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>MACINTERFACE.;30) (PRETTYCOMPRINT MACINTERFACECOMS) (RPAQQ MACINTERFACECOMS [(FNS INTITLEBAR INCORNER MACWINDOW.BUTTONEVENTFN MACWINDOW.BUTTONEVENTFN.ANYWHERE MACWINDOW) (FNS MACINT\TEDIT.BUTTONEVENTFN MACINT\SEDIT-BUTTONEVENTFN MACINT-ADD-EXEC MACINT-DEBUGGER-BUTTON-EVENT MACINT-\ITEM.WINDOW.BUTTON.HANDLER MACINT-SNAPW) (INITVARS (MACINTERFACECORNERMARGIN 25)) (P (MOVD? '\TEDIT.BUTTONEVENTFN 'MACORIG\TEDIT.BUTTONEVENTFN) (MOVD 'MACINT\TEDIT.BUTTONEVENTFN '\TEDIT.BUTTONEVENTFN)) (P (MOVD? 'SEDIT::BUTTONEVENTFN 'MACORIG\SEDIT-BUTTONEVENTFN) (MOVD 'MACINT\SEDIT-BUTTONEVENTFN 'SEDIT::BUTTONEVENTFN)) (P (MOVD? 'ADD-EXEC 'MACORIG-ADD-EXEC) (MOVD 'MACINT-ADD-EXEC 'ADD-EXEC)) (P (MOVD? 'DBG::DEBUGGER-BUTTON-EVENT 'MACORIG-DEBUGGER-BUTTON-EVENT) (MOVD 'MACINT-DEBUGGER-BUTTON-EVENT 'DBG::DEBUGGER-BUTTON-EVENT)) (P (MOVD? '\ITEM.WINDOW.BUTTON.HANDLER 'MACORIG-\ITEM.WINDOW.BUTTON.HANDLER) (MOVD 'MACINT-\ITEM.WINDOW.BUTTON.HANDLER '\ITEM.WINDOW.BUTTON.HANDLER)) (P (MOVD? 'SNAPW 'MACORIG-SNAPW) (MOVD 'MACINT-SNAPW 'SNAPW)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA MACINT-ADD-EXEC]) (DEFINEQ (INTITLEBAR [LAMBDA (WINDOW) (* ; "Edited 3-May-2020 20:38 by rmk:") (IGREATERP (LASTMOUSEY WINDOW) (FETCH TOP OF (DSPCLIPPINGREGION NIL WINDOW]) (INCORNER [LAMBDA (WINDOW MARGIN) (* ; "Edited 13-May-2020 14:26 by rmk:") (* ; "Edited 10-May-2020 12:41 by rmk:") (* ; "Edited 3-May-2020 20:43 by rmk:") (CL:UNLESS MARGIN (SETQ MARGIN MACINTERFACECORNERMARGIN)) (LET ((CR (DSPCLIPPINGREGION NIL WINDOW)) (X (LASTMOUSEX WINDOW)) (Y (LASTMOUSEY WINDOW))) (IF (ILEQ (IABS (IDIFFERENCE X (FETCH LEFT OF CR))) MARGIN) THEN (* ;; "GREATERP puts it in title bar") (IF (IGREATERP Y (FETCH TOP OF CR)) THEN 'LEFTTOP ELSEIF (ILEQ (IABS (IDIFFERENCE Y (FETCH BOTTOM OF CR))) MARGIN) THEN 'LEFTBOTTOM) ELSEIF (ILEQ (IABS (IDIFFERENCE X (FETCH RIGHT OF CR))) MARGIN) THEN (IF (IGREATERP Y (FETCH TOP OF CR)) THEN 'RIGHTTOP ELSEIF (ILEQ (IABS (IDIFFERENCE Y (FETCH BOTTOM OF CR))) MARGIN) THEN 'RIGHTBOTTOM]) (MACWINDOW.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 23-May-2020 08:34 by rmk:") (* ; "Edited 10-May-2020 03:35 by rmk:") (* ; "Edited 3-May-2020 21:18 by rmk:") (IF (MOUSESTATE (ONLY LEFT)) THEN (TOTOPW WINDOW) (LET (REGION (CORNER (INCORNER WINDOW))) (IF CORNER THEN (* ;;  "The upper corners may be in the title bar, near the side, so test this first") (SETQ REGION (WINDOWPROP WINDOW 'REGION)) [LET ((LEFT (FETCH LEFT OF REGION)) (RIGHT (FETCH RIGHT OF REGION)) (TOP (FETCH TOP OF REGION)) (BOTTOM (FETCH BOTTOM OF REGION))) (SHAPEW WINDOW (GETREGION NIL NIL NIL NIL NIL (SELECTQ CORNER (RIGHTBOTTOM (LIST LEFT TOP RIGHT BOTTOM)) (LEFTBOTTOM (LIST RIGHT TOP LEFT BOTTOM)) (RIGHTTOP (LIST LEFT BOTTOM RIGHT TOP)) (LEFTTOP (LIST RIGHT BOTTOM LEFT TOP)) (SHOULDNT] T ELSEIF (INTITLEBAR WINDOW) THEN (MOVEW WINDOW) T ELSEIF (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) THEN (APPLY* (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) WINDOW))) ELSEIF (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) THEN (APPLY* (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) WINDOW]) (MACWINDOW.BUTTONEVENTFN.ANYWHERE [LAMBDA (WINDOW) (* ; "Edited 28-May-2020 18:00 by rmk:") (* ; "Edited 23-May-2020 08:34 by rmk:") (* ; "Edited 10-May-2020 03:35 by rmk:") (* ; "Edited 3-May-2020 21:18 by rmk:") (* ;; "Move if left-click anywhere, not just titlebar") (IF (MOUSESTATE (ONLY LEFT)) THEN (TOTOPW WINDOW) (LET (REGION (CORNER (INCORNER WINDOW))) (IF CORNER THEN (* ;;  "The upper corners may be in the title bar, near the side, so test this first") (SETQ REGION (WINDOWPROP WINDOW 'REGION)) [LET ((LEFT (FETCH LEFT OF REGION)) (RIGHT (FETCH RIGHT OF REGION)) (TOP (FETCH TOP OF REGION)) (BOTTOM (FETCH BOTTOM OF REGION))) (SHAPEW WINDOW (GETREGION NIL NIL NIL NIL NIL (SELECTQ CORNER (RIGHTBOTTOM (LIST LEFT TOP RIGHT BOTTOM)) (LEFTBOTTOM (LIST RIGHT TOP LEFT BOTTOM)) (RIGHTTOP (LIST LEFT BOTTOM RIGHT TOP)) (LEFTTOP (LIST RIGHT BOTTOM LEFT TOP)) (SHOULDNT] T ELSE (MOVEW WINDOW) T)) ELSEIF (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) THEN (APPLY* (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) WINDOW]) (MACWINDOW [LAMBDA (WINDOW ANYWHERE) (* ; "Edited 28-May-2020 17:58 by rmk:") (* ; "Edited 18-May-2020 20:11 by rmk:") (* ; "Edited 10-May-2020 14:20 by rmk:") (* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn.")  (* ; "Edited 3-May-2020 21:17 by rmk:") (CL:UNLESS (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN)) (WINDOWPROP WINDOW 'BUTTONEVENTFN (IF ANYWHERE THEN (FUNCTION MACWINDOW.BUTTONEVENTFN.ANYWHERE) ELSE (FUNCTION MACWINDOW.BUTTONEVENTFN)))) WINDOW]) ) (DEFINEQ (MACINT\TEDIT.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 10-May-2020 03:31 by rmk:") (CL:WHEN (LISTP WINDOW) (SETQ WINDOW (CAR WINDOW))) (OR (MACWINDOW.BUTTONEVENTFN WINDOW) (MACORIG\TEDIT.BUTTONEVENTFN WINDOW]) (MACINT\SEDIT-BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 10-May-2020 03:31 by rmk:") (OR (MACWINDOW.BUTTONEVENTFN WINDOW) (MACORIG\SEDIT-BUTTONEVENTFN WINDOW]) (MACINT-ADD-EXEC [LAMBDA U (* ; "Edited 10-May-2020 03:31 by rmk:") (LET [(PROC (APPLY (FUNCTION MACORIG-ADD-EXEC) (FOR N FROM 1 TO U COLLECT (ARG U N] (* ;; "For some reason, the window may not be there immediately") (DISMISS 100) (MACWINDOW (PROCESSPROP PROC 'WINDOW)) PROC]) (MACINT-DEBUGGER-BUTTON-EVENT [LAMBDA (WINDOW) (* ; "Edited 10-May-2020 03:31 by rmk:") (OR (MACWINDOW.BUTTONEVENTFN WINDOW) (MACORIG-DEBUGGER-BUTTON-EVENT WINDOW]) (MACINT-\ITEM.WINDOW.BUTTON.HANDLER [LAMBDA (WINDOW) (* ; "Edited 16-May-2020 22:35 by rmk:") (* ; "Edited 10-May-2020 03:31 by rmk:") (OR (MACWINDOW.BUTTONEVENTFN WINDOW) (MACORIG-\ITEM.WINDOW.BUTTON.HANDLER WINDOW]) (MACINT-SNAPW [LAMBDA NIL (* ; "Edited 18-May-2020 17:20 by rmk:") (LET ((W (MACORIG-SNAPW))) [WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (W) (TOTOPW W) (MOVEW W] W]) ) (RPAQ? MACINTERFACECORNERMARGIN 25) (MOVD? '\TEDIT.BUTTONEVENTFN 'MACORIG\TEDIT.BUTTONEVENTFN) (MOVD 'MACINT\TEDIT.BUTTONEVENTFN '\TEDIT.BUTTONEVENTFN) (MOVD? 'SEDIT::BUTTONEVENTFN 'MACORIG\SEDIT-BUTTONEVENTFN) (MOVD 'MACINT\SEDIT-BUTTONEVENTFN 'SEDIT::BUTTONEVENTFN) (MOVD? 'ADD-EXEC 'MACORIG-ADD-EXEC) (MOVD 'MACINT-ADD-EXEC 'ADD-EXEC) (MOVD? 'DBG::DEBUGGER-BUTTON-EVENT 'MACORIG-DEBUGGER-BUTTON-EVENT) (MOVD 'MACINT-DEBUGGER-BUTTON-EVENT 'DBG::DEBUGGER-BUTTON-EVENT) (MOVD? '\ITEM.WINDOW.BUTTON.HANDLER 'MACORIG-\ITEM.WINDOW.BUTTON.HANDLER) (MOVD 'MACINT-\ITEM.WINDOW.BUTTON.HANDLER '\ITEM.WINDOW.BUTTON.HANDLER) (MOVD? 'SNAPW 'MACORIG-SNAPW) (MOVD 'MACINT-SNAPW 'SNAPW) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MACINT-ADD-EXEC) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (1857 8826 (INTITLEBAR 1867 . 2087) (INCORNER 2089 . 3504) (MACWINDOW.BUTTONEVENTFN 3506 . 5720) (MACWINDOW.BUTTONEVENTFN.ANYWHERE 5722 . 7859) (MACWINDOW 7861 . 8824)) (8827 10721 ( MACINT\TEDIT.BUTTONEVENTFN 8837 . 9128) (MACINT\SEDIT-BUTTONEVENTFN 9130 . 9357) (MACINT-ADD-EXEC 9359 . 9783) (MACINT-DEBUGGER-BUTTON-EVENT 9785 . 10016) (MACINT-\ITEM.WINDOW.BUTTON.HANDLER 10018 . 10370 ) (MACINT-SNAPW 10372 . 10719))))) STOP \ No newline at end of file diff --git a/lispusers/MACINTERFACE.~52~ b/lispusers/MACINTERFACE.~52~ deleted file mode 100644 index 6b135c9b..00000000 --- a/lispusers/MACINTERFACE.~52~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 8-Aug-2020 15:48:17"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>MACINTERFACE.;52 14335 changes to%: (VARS MACINTERFACECOMS) previous date%: " 8-Aug-2020 08:01:06" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>MACINTERFACE.;51) (PRETTYCOMPRINT MACINTERFACECOMS) (RPAQQ MACINTERFACECOMS [ (* ;; "Externals") (COMS (FNS MACWINDOW MACWINDOW.SETUP MACWINDOW.UNSETUP) (INITVARS (MACINTERFACECORNERMARGIN 25))) (* ;; "Internals") [COMS (FNS INTITLEBAR INCORNER MACWINDOW.BUTTONEVENTFN MACWINDOW.BUTTONEVENTFN.ANYWHERE) (* ;; "Behavior for some known window creators") (FNS MACINT-ADD-EXEC MACINT-SNAPW) (FNS TEDIT.MACINTERFACE TEDIT.SELECTALL) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (TEDIT.MACINTERFACE) (* ;; "Inspector") (MACWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MACWINDOW.SETUP 'ONEDINSPECT.BUTTONEVENTFN)) (MACWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MACWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MACWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MACWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MACWINDOW.SETUP 'SNAPW 'MACINT-SNAPW) (* ;; "New execs") (MACWINDOW.SETUP 'ADD-EXEC 'MACINT-ADD-EXEC) (* ;; "Existing exec of the load") (MACWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA MACINT-ADD-EXEC]) (* ;; "Externals") (DEFINEQ (MACWINDOW [LAMBDA (WINDOW ANYWHERE) (* ; "Edited 23-Jun-2020 16:01 by rmk:") (* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn.") (CL:UNLESS (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN)) (WINDOWPROP WINDOW 'BUTTONEVENTFN (IF ANYWHERE THEN (FUNCTION MACWINDOW.BUTTONEVENTFN.ANYWHERE) ELSE (FUNCTION MACWINDOW.BUTTONEVENTFN)))) WINDOW]) (MACWINDOW.SETUP [LAMBDA (ORIGFN MACWINDOWFN ANYWHERE) (* ; "Edited 24-Jun-2020 15:09 by rmk:") (* ;; "ORIGFN is either a function that creates windows of a given type (e.g. SNAPW or ADD-EXEC) or the known BUTTONEVENTFN of a class of windows.") (* ;; "Moves ORIGNFN to a new name, prefixed with MACORIG-.") (* ;; "If MACWINDOWFN is given, then that replaces the original definition of ORIGFN, and presumably knows how to call the renamed ORIGFN under the write circumstances. This is typically the case where ORIGFN is a window creator.") (* ;; "Otherwise, ORIGFN is taken to be the BUTTONEVENTFN for a class of windows, and its new definition is defaulted to one that maps left-clicks in appropriate areas into Mac window operations. If not in appropriate areas, then the renamed ORIGNFN is called to give the original button behavior.") (* ;; "If ANYWHERE, moving will happen for any click not in one of the shaping corners.") (* ;; "The renamed function has arguments in addition to WINDOW: the new name for the original function, if MACWINDOFN is provided, and the value specified here for ANYWHERE.") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MACORIG- ORIGFN) PKGNAME)) (MOVD? ORIGFN RENAMEDORIG) (IF MACWINDOWFN THEN (MOVD MACWINDOWFN ORIGFN) ELSE (PUTD ORIGFN `(LAMBDA (WINDOW) (MACWINDOW.BUTTONEVENTFN WINDOW (FUNCTION ,RENAMEDORIG) ,ANYWHERE]) (MACWINDOW.UNSETUP [LAMBDA (ORIGFN) (* ; "Edited 6-Jul-2020 13:04 by rmk:") (* ; "Edited 24-Jun-2020 15:09 by rmk:") (* ;; "Moves the renamed original function back to its original name") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MACORIG- ORIGFN) PKGNAME)) (CL:WHEN (GETD RENAMEDORIG) (MOVD RENAMEDORIG ORIGFN]) ) (RPAQ? MACINTERFACECORNERMARGIN 25) (* ;; "Internals") (DEFINEQ (INTITLEBAR [LAMBDA (WINDOW) (* ; "Edited 3-May-2020 20:38 by rmk:") (IGREATERP (LASTMOUSEY WINDOW) (FETCH TOP OF (DSPCLIPPINGREGION NIL WINDOW]) (INCORNER [LAMBDA (WINDOW MARGIN) (* ; "Edited 13-May-2020 14:26 by rmk:") (* ; "Edited 10-May-2020 12:41 by rmk:") (* ; "Edited 3-May-2020 20:43 by rmk:") (CL:UNLESS MARGIN (SETQ MARGIN MACINTERFACECORNERMARGIN)) (LET ((CR (DSPCLIPPINGREGION NIL WINDOW)) (X (LASTMOUSEX WINDOW)) (Y (LASTMOUSEY WINDOW))) (IF (ILEQ (IABS (IDIFFERENCE X (FETCH LEFT OF CR))) MARGIN) THEN (* ;; "GREATERP puts it in title bar") (IF (IGREATERP Y (FETCH TOP OF CR)) THEN 'LEFTTOP ELSEIF (ILEQ (IABS (IDIFFERENCE Y (FETCH BOTTOM OF CR))) MARGIN) THEN 'LEFTBOTTOM) ELSEIF (ILEQ (IABS (IDIFFERENCE X (FETCH RIGHT OF CR))) MARGIN) THEN (IF (IGREATERP Y (FETCH TOP OF CR)) THEN 'RIGHTTOP ELSEIF (ILEQ (IABS (IDIFFERENCE Y (FETCH BOTTOM OF CR))) MARGIN) THEN 'RIGHTBOTTOM]) (MACWINDOW.BUTTONEVENTFN [LAMBDA (WINDOW ORIGFUNCTION ANYWHERE) (* ; "Edited 24-Jun-2020 20:23 by rmk:") (* ; "Edited 23-May-2020 08:34 by rmk:") (* ; "Edited 10-May-2020 03:35 by rmk:") (* ; "Edited 3-May-2020 21:18 by rmk:") (IF (AND (MOUSESTATE (ONLY LEFT)) (EQ LASTKEYBOARD 0)) THEN (TOTOPW WINDOW) (LET (REGION (CORNER (INCORNER WINDOW))) (IF CORNER THEN (* ;;  "The upper corners may be in the title bar, near the side, so test this first") (SETQ REGION (WINDOWPROP WINDOW 'REGION)) [LET ((LEFT (FETCH LEFT OF REGION)) (RIGHT (FETCH RIGHT OF REGION)) (TOP (FETCH TOP OF REGION)) (BOTTOM (FETCH BOTTOM OF REGION))) (SHAPEW WINDOW (GETREGION NIL NIL NIL NIL NIL (SELECTQ CORNER (RIGHTBOTTOM (LIST LEFT TOP RIGHT BOTTOM)) (LEFTBOTTOM (LIST RIGHT TOP LEFT BOTTOM)) (RIGHTTOP (LIST LEFT BOTTOM RIGHT TOP)) (LEFTTOP (LIST RIGHT BOTTOM LEFT TOP)) (SHOULDNT] T ELSEIF (OR ANYWHERE (INTITLEBAR WINDOW)) THEN (MOVEW WINDOW) T ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW))) ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW]) (MACWINDOW.BUTTONEVENTFN.ANYWHERE [LAMBDA (WINDOW) (* ; "Edited 24-Jun-2020 13:24 by rmk:") (* ;; "Move if left-click anywhere, not just titlebar") (MACWINDOW.BUTTONEVENTFN NIL T]) ) (* ;; "Behavior for some known window creators") (DEFINEQ (MACINT-ADD-EXEC [LAMBDA U (* ; "Edited 24-Jun-2020 14:23 by rmk:") (LET [(PROC (APPLY (FUNCTION MACORIG-ADD-EXEC) (FOR N FROM 1 TO U COLLECT (ARG U N] (* ;; "For some reason, the window may not be there immediately") (DISMISS 100) (MACWINDOW (PROCESSPROP PROC 'WINDOW)) PROC]) (MACINT-SNAPW [LAMBDA NIL (* ; "Edited 24-Jun-2020 13:19 by rmk:") (* ;; "No point in shaping a snap window, just move it.;;") (* ;; "This changes the creation function (SNAPW), since snap windows otherwise don't have a BUTTONEVENTN") (LET ((W (MACORIG-SNAPW))) [WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (W) (TOTOPW W) (MOVEW W] W]) ) (DEFINEQ (TEDIT.MACINTERFACE [LAMBDA NIL (* ; "Edited 8-Aug-2020 07:58 by rmk:") (MACWINDOW.SETUP '\TEDIT.BUTTONEVENTFN) (* ;; "All") (TEDIT.SETFUNCTION (CHARCODE "1,a") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,A") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (* ;; "Quit") (TEDIT.SETFUNCTION (CHARCODE "1,q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,Q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE]) (TEDIT.SELECTALL [LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 3-May-2020 17:29 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (CL:WHEN TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch TEXTLEN of (TEXTOBJ TEXTSTREAM))) 'LEFT))]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (TEDIT.MACINTERFACE) (* ;; "Inspector") (MACWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MACWINDOW.SETUP  (QUOTE ONEDINSPECT.BUTTONEVENTFN))) (MACWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MACWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MACWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MACWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MACWINDOW.SETUP 'SNAPW 'MACINT-SNAPW) (* ;; "New execs") (MACWINDOW.SETUP 'ADD-EXEC 'MACINT-ADD-EXEC) (* ;; "Existing exec of the load") (MACWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW)) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MACINT-ADD-EXEC) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3345 6723 (MACWINDOW 3355 . 3996) (MACWINDOW.SETUP 3998 . 5914) (MACWINDOW.UNSETUP 5916 . 6721)) (6792 11103 (INTITLEBAR 6802 . 7022) (INCORNER 7024 . 8439) (MACWINDOW.BUTTONEVENTFN 8441 . 10850) (MACWINDOW.BUTTONEVENTFN.ANYWHERE 10852 . 11101)) (11161 12138 (MACINT-ADD-EXEC 11171 . 11595) (MACINT-SNAPW 11597 . 12136)) (12139 13098 (TEDIT.MACINTERFACE 12149 . 12767) (TEDIT.SELECTALL 12769 . 13096))))) STOP \ No newline at end of file diff --git a/lispusers/MODERNIZE b/lispusers/MODERNIZE new file mode 100644 index 00000000..89ee43a4 --- /dev/null +++ b/lispusers/MODERNIZE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "27-Feb-2021 18:14:36"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>MODERNIZE.;11 20163 changes to%: (FNS MODERNWINDOW.BUTTONEVENTFN) previous date%: "26-Feb-2021 21:20:15" {DSK}kaplan>Local>medley3.5>git-medley>lispusers>MODERNIZE.;10) (PRETTYCOMPRINT MODERNIZECOMS) (RPAQQ MODERNIZECOMS [ (* ;; "Externals") (COMS (FNS MODERNWINDOW MODERNWINDOW.SETUP UNMODERNWINDOW MODERNWINDOW.UNSETUP) (INITVARS (MODERN-WINDOW-MARGIN 25))) (* ;; "Internals") [COMS (FNS MODERNWINDOW.BUTTONEVENTFN MODERNWINDOW.BUTTONEVENTFN.ANYWHERE NEARTOP NEARESTCORNER INCORNER.REGION) (* ;; "Behavior for some known window creators") (FNS MODERN-ADD-EXEC MODERN-SNAPW TOTOPW.MODERNIZE) (* ;; "Add some Meta commands") (FNS TEDIT.MODERNIZE TEDIT.SELECTALL) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (TEDIT.MODERNIZE) (* ;; "Inspector") (MODERNWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MODERNWINDOW.SETUP 'ONEDINSPECT.BUTTONEVENTFN)) (MODERNWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MODERNWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MODERNWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MODERNWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MODERNWINDOW.SETUP 'SNAPW 'MODERN-SNAPW) (* ;; "New execs") (MODERNWINDOW.SETUP 'ADD-EXEC 'MODERN-ADD-EXEC) (* ;; "Existing exec of the load") (MODERNWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW)) (* ;; "Table browser (for filebrowser)") (MODERNWINDOW.SETUP 'TB.BUTTONEVENTFN) (* ;; "Grapher") (MODERNWINDOW.SETUP 'APPLYTOSELECTEDNODE) (* ;; "Promptwindow") (MODERNWINDOW PROMPTWINDOW T] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA MODERN-ADD-EXEC]) (* ;; "Externals") (DEFINEQ (MODERNWINDOW [LAMBDA (WINDOW ANYWHERE) (* ; "Edited 22-Feb-2021 16:44 by rmk:") (* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn.") (CL:UNLESS (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN) (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN)) (WINDOWPROP WINDOW 'BUTTONEVENTFN (IF ANYWHERE THEN (FUNCTION MODERNWINDOW.BUTTONEVENTFN.ANYWHERE) ELSE (FUNCTION MODERNWINDOW.BUTTONEVENTFN)))) WINDOW]) (MODERNWINDOW.SETUP [LAMBDA (ORIGFN MODERNWINDOWFN ANYWHERE) (* ; "Edited 22-Feb-2021 16:42 by rmk:") (* ;; "ORIGFN is either a function that creates windows of a given type (e.g. SNAPW or ADD-EXEC) or the known BUTTONEVENTFN of a class of windows.") (* ;; "Moves ORIGNFN to a new name, prefixed with MODERNORIG-.") (* ;; "If MODERNWINDOWFN is given, then that replaces the original definition of ORIGFN, and presumably knows how to call the renamed ORIGFN under the right circumstances. This is typically the case where ORIGFN is a window creator.") (* ;; "Otherwise, ORIGFN is taken to be the BUTTONEVENTFN for a class of windows, and its new definition is defaulted to one that maps left-clicks in appropriate areas into modern window operations. If not in appropriate areas, then the renamed ORIGNFN is called to give the original button behavior.") (* ;; "If ANYWHERE, moving will happen for any click not in one of the shaping corners.") (* ;; "The renamed function has arguments in addition to WINDOW: the new name for the original function, if MODERNWINDOFN is provided, and the value specified here for ANYWHERE.") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MODERN-ORIG- ORIGFN) PKGNAME)) (MOVD? ORIGFN RENAMEDORIG) (IF MODERNWINDOWFN THEN (MOVD MODERNWINDOWFN ORIGFN) ELSE (PUTD ORIGFN `(LAMBDA (WINDOW) (MODERNWINDOW.BUTTONEVENTFN WINDOW (FUNCTION ,RENAMEDORIG) ,ANYWHERE]) (UNMODERNWINDOW [LAMBDA (WINDOW) (* ; "Edited 22-Feb-2021 16:44 by rmk:") (* ;; "Restores original window behavior") (CL:WHEN (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN) (WINDOWPROP WINDOW 'BUTTONEVENTFN (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN)) (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN NIL)) WINDOW]) (MODERNWINDOW.UNSETUP [LAMBDA (ORIGFN) (* ; "Edited 22-Feb-2021 16:45 by rmk:") (* ; "Edited 24-Jun-2020 15:09 by rmk:") (* ;; "Moves the renamed original function back to its original name") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MODERN-ORIG- ORIGFN) PKGNAME)) (CL:WHEN (GETD RENAMEDORIG) (MOVD RENAMEDORIG ORIGFN]) ) (RPAQ? MODERN-WINDOW-MARGIN 25) (* ;; "Internals") (DEFINEQ (MODERNWINDOW.BUTTONEVENTFN [LAMBDA (WINDOW ORIGFUNCTION ANYWHERE) (* ; "Edited 27-Feb-2021 17:57 by rmk:") (IF (AND (MOUSESTATE (ONLY LEFT)) (EQ LASTKEYBOARD 0)) THEN (TOTOPW WINDOW) (LET [CORNER TOPMARGIN (MAINREGION (WINDOWPROP WINDOW 'REGION)) (ATTACHEDREGION (ATTACHEDWINDOWREGION (CENTRALWINDOW WINDOW] (* ;; "If the window has a TOPMARGIN property, that tells us that it does not have a canonical title but may still have a title-like attached window just above the main window. The TOPMARGIN should be 0 in that case.") (* ;; "This is particularly the case of FILEBROWSER windows, where the the modified ATTACHEDWINDOWTOTOPFN drives the click here. ") (SETQ TOPMARGIN (IF (WINDOWPROP WINDOW 'TOPMARGIN) ELSEIF (WINDOWPROP WINDOW 'TITLE) THEN (FONTPROP WindowTitleDisplayStream 'HEIGHT) ELSE MODERN-WINDOW-MARGIN)) (SETQ CORNER (INCORNER.REGION MAINREGION TOPMARGIN)) (IF CORNER THEN (* ;;  "The upper corners may be in the title bar, near the side, so test corners before titlebar.") (* ;; "We are in the corner of the main window, so we are reshaping. But the ghost region should include all of the attached windows, and the starting cursor should be positioned at the corner closest to the selected corner of the main window.") (* ;; "WINDOWREGION includes the attached windows") (LET ((LEFT (FETCH LEFT OF ATTACHEDREGION)) (RIGHT (FETCH RIGHT OF ATTACHEDREGION)) (TOP (FETCH TOP OF ATTACHEDREGION)) (BOTTOM (FETCH BOTTOM OF ATTACHEDREGION)) STARTINGREGION) (* ;; "\CURSORPOSITION moves the mouse to the tracking corner of the ghost region, in screen coordinates, so that the mouse starts out at the tracking corner of the ghost region, even if there are attached windows (as in the filebrowser) that overhang the corner and the initiating click was at the corner of the mainwindow.") (CL:UNLESS (EQ 'DON'T (WINDOWPROP WINDOW 'RESHAPEFN)) [SETQ STARTINGREGION (GETREGION NIL NIL NIL NIL NIL (SELECTQ CORNER (RIGHTBOTTOM (\CURSORPOSITION RIGHT BOTTOM) (GETMOUSESTATE) (LIST LEFT TOP RIGHT BOTTOM)) (LEFTBOTTOM (\CURSORPOSITION LEFT BOTTOM) (GETMOUSESTATE) (LIST RIGHT TOP LEFT BOTTOM)) (RIGHTTOP (\CURSORPOSITION RIGHT TOP) (GETMOUSESTATE) (LIST LEFT BOTTOM RIGHT TOP)) (LEFTTOP (\CURSORPOSITION LEFT TOP) (GETMOUSESTATE) (LIST RIGHT BOTTOM LEFT TOP)) (SHOULDNT]) (SHAPEW (CL:IF (MEMB 'SHAPEW (WINDOWPROP WINDOW 'PASSTOMAINCOMS)) (WINDOWPROP WINDOW 'MAINWINDOW) WINDOW) STARTINGREGION)) T ELSEIF (OR ANYWHERE (NEARTOP MAINREGION TOPMARGIN)) THEN (NEARESTCORNER ATTACHEDREGION) (MOVEW (CL:IF (MEMB 'MOVEW (WINDOWPROP WINDOW 'PASSTOMAINCOMS)) (WINDOWPROP WINDOW 'MAINWINDOW) WINDOW)) T ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW))) ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW]) (MODERNWINDOW.BUTTONEVENTFN.ANYWHERE [LAMBDA (WINDOW) (* ; "Edited 22-Feb-2021 16:31 by rmk:") (* ; "Edited 24-Jun-2020 13:24 by rmk:") (* ;; "Move if left-click anywhere, not just titlebar") (MODERNWINDOW.BUTTONEVENTFN WINDOW NIL T]) (NEARTOP [LAMBDA (MAINREGION TOPMARGIN) (* ; "Edited 12-Feb-2021 23:19 by rmk:") (* ;; "True if the MOUSEY is near the top of MAINREGION. That means in the title bar for titled windows, otherwise a short distance below the top of the window. (Could be in the border?)") (IGREATERP LASTMOUSEY (IDIFFERENCE (FETCH TOP OF MAINREGION) TOPMARGIN]) (NEARESTCORNER [LAMBDA (REGION) (* ; "Edited 14-Feb-2021 21:46 by rmk:") (* ;; "Moves the cursor to the corner of REGION that is closest to the current LASTMOUSEX AND LASTMOUSEY") (\CURSORPOSITION (CL:IF (ILESSP (IDIFFERENCE LASTMOUSEX (FETCH LEFT OF REGION)) (IDIFFERENCE (FETCH RIGHT OF REGION) LASTMOUSEX)) (FETCH LEFT OF REGION) (FETCH RIGHT OF REGION)) (CL:IF (ILESSP (IDIFFERENCE LASTMOUSEY (FETCH BOTTOM OF REGION)) (IDIFFERENCE (FETCH TOP OF REGION) LASTMOUSEY)) (FETCH BOTTOM OF REGION) (FETCH TOP OF REGION))]) (INCORNER.REGION [LAMBDA (MAINREGION TOPMARGIN) (* ; "Edited 22-Feb-2021 16:27 by rmk:") (* ;; "MAINREGION, LASTMOUSEX, LASTMOUSEY in screen coordinates.") (* ;; "TOPMARGIN is the height of the titlebar for titled windows, otherwise the margin at the top of the window's content that we regard as the top. ") (IF (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH LEFT OF MAINREGION))) MODERN-WINDOW-MARGIN) THEN (IF (NEARTOP MAINREGION TOPMARGIN) THEN 'LEFTTOP ELSEIF (ILEQ LASTMOUSEY (IPLUS MODERN-WINDOW-MARGIN (FETCH BOTTOM OF MAINREGION))) THEN 'LEFTBOTTOM) ELSEIF (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH RIGHT OF MAINREGION))) MODERN-WINDOW-MARGIN) THEN (IF (NEARTOP MAINREGION TOPMARGIN) THEN 'RIGHTTOP ELSEIF (ILEQ LASTMOUSEY (IPLUS MODERN-WINDOW-MARGIN (FETCH BOTTOM OF MAINREGION))) THEN 'RIGHTBOTTOM]) ) (* ;; "Behavior for some known window creators") (DEFINEQ (MODERN-ADD-EXEC [LAMBDA U (* ; "Edited 22-Feb-2021 16:41 by rmk:") (LET [(PROC (APPLY (FUNCTION MODERN-ORIG-ADD-EXEC) (FOR N FROM 1 TO U COLLECT (ARG U N] (* ;; "For some reason, the window may not be there immediately") (DISMISS 100) (MODERNWINDOW (PROCESSPROP PROC 'WINDOW)) PROC]) (MODERN-SNAPW [LAMBDA NIL (* ; "Edited 22-Feb-2021 16:41 by rmk:") (* ;; "No point in shaping a snap window, just move it.;;") (* ;; "This changes the creation function (SNAPW), since snap windows otherwise don't have a BUTTONEVENTN") (LET ((W (MODERN-ORIG-SNAPW))) [WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (W) (TOTOPW W) (MOVEW W] W]) (TOTOPW.MODERNIZE [LAMBDA (WINDOW) (* ; "Edited 22-Feb-2021 16:31 by rmk:") (* ;; "This replaces the TOTOPW BUTTONEVENTFN on an attached window where the click is then directed to the MAINWINDOW.") (TOTOPW WINDOW) (LET ((MAIN (MAINWINDOW WINDOW T))) (CL:WHEN MAIN (MODERNWINDOW.BUTTONEVENTFN MAIN (WINDOWPROP MAIN 'BUTTONEVENTFN)))]) ) (* ;; "Add some Meta commands") (DEFINEQ (TEDIT.MODERNIZE [LAMBDA NIL (* ; "Edited 22-Feb-2021 16:28 by rmk:") (CL:WHEN (GETD '\TEDIT.BUTTONEVENTFN) (MODERNWINDOW.SETUP '\TEDIT.BUTTONEVENTFN) (* ;; "All") (TEDIT.SETFUNCTION (CHARCODE "1,a") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,A") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (* ;; "Quit") (TEDIT.SETFUNCTION (CHARCODE "1,q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,Q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE))]) (TEDIT.SELECTALL [LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 3-May-2020 17:29 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (CL:WHEN TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch TEXTLEN of (TEXTOBJ TEXTSTREAM))) 'LEFT))]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (TEDIT.MODERNIZE) (* ;; "Inspector") (MODERNWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MODERNWINDOW.SETUP  (QUOTE ONEDINSPECT.BUTTONEVENTFN))) (MODERNWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MODERNWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MODERNWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MODERNWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MODERNWINDOW.SETUP 'SNAPW 'MODERN-SNAPW) (* ;; "New execs") (MODERNWINDOW.SETUP 'ADD-EXEC 'MODERN-ADD-EXEC) (* ;; "Existing exec of the load") (MODERNWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW)) (* ;; "Table browser (for filebrowser)") (MODERNWINDOW.SETUP 'TB.BUTTONEVENTFN) (* ;; "Grapher") (MODERNWINDOW.SETUP 'APPLYTOSELECTEDNODE) (* ;; "Promptwindow") (MODERNWINDOW PROMPTWINDOW T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MODERN-ADD-EXEC) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (4168 7994 (MODERNWINDOW 4178 . 4836) (MODERNWINDOW.SETUP 4838 . 6782) (UNMODERNWINDOW 6784 . 7178) (MODERNWINDOW.UNSETUP 7180 . 7992)) (8059 16072 (MODERNWINDOW.BUTTONEVENTFN 8069 . 13080) (MODERNWINDOW.BUTTONEVENTFN.ANYWHERE 13082 . 13453) (NEARTOP 13455 . 13891) (NEARESTCORNER 13893 . 14772) (INCORNER.REGION 14774 . 16070)) (16130 17548 (MODERN-ADD-EXEC 16140 . 16571) (MODERN-SNAPW 16573 . 17116) (TOTOPW.MODERNIZE 17118 . 17546)) (17589 18672 (TEDIT.MODERNIZE 17599 . 18341) ( TEDIT.SELECTALL 18343 . 18670))))) STOP \ No newline at end of file diff --git a/lispusers/MODERNIZE.LCOM b/lispusers/MODERNIZE.LCOM new file mode 100644 index 00000000..189ea08d Binary files /dev/null and b/lispusers/MODERNIZE.LCOM differ diff --git a/lispusers/MODERNIZE.TXT b/lispusers/MODERNIZE.TXT new file mode 100644 index 00000000..50138230 --- /dev/null +++ b/lispusers/MODERNIZE.TXT @@ -0,0 +1,76 @@ +MODERNIZE documentation + + Ron Kaplan, February 2021 + +[A renaming of an earlier MACINTERFACE package] + +MODERNIZE is a simple Lispusers package that changes the mouse actions on Medley windows so that moving and shaping can be done in a way that approximates the behavior of windows on modern platforms, Mac, Windows, etc. It also adds some meta keys to also emulate more conventional behavior. + +Thus, for a window that has been created or transformed in this way, you can move the window by left-clicking in the title bar and dragging the window's ghost region. Or you can reshape by clicking in a corner of the title bar or near the bottom of the window to drag out the ghost region by that corner. + +The menu behavior for other buttons or buttons clicked in other positions is unchanged. + + +For bottom corners, "near" means inside the window within MODERN-WINDOW-MARGIN (initially 25) pixels above or to the left/right of the corner. + +For top corners, "near" means within the title bar and within the margin from the left/right edges. + +(Windows that don't have a title-bar, like Snap windows, can be set up so that moving can happen by clicking anywhere, and shaping at the top is determined by the margin inside the window region.) + +When the package is loaded, this behavior is installed for the following kinds of windows: + + Tedit + Debugger/break + Sedit + Inspector + Snap + Exec + File Browser + Grapher + +The function MODERNWINDOW.SETUP establishes the new behavior for classes of windows: + +(MODERNWINDOW.SETUP ORIGFN MODERNWINDOWFN ANYWHERE) + +ORIGFN is either the name of the BUTTONEVENTFN for a class of windows (e.g. \TEDIT.BUTTONEVENTFN for Tedit windows) or it is a function that creates windows of a particulate kind (e.g. SNAPW or ADD-EXEC). + +MODERNWINDOW.SETUP moves the definition of ORIGFN to the name (PACK* 'MODERN-ORIG- ORIGFN), and then provides a new definition for ORIGFN that does the moving or reshaping for clicks in the triggering locations, and otherwise passes control through to the original definition. + +If ORIGNFN is a button event function, then MODERNWINDOWFN should not be specified. In that case a new definition for ORIGFN is constructed to provide the desired windowing behavior. + +Otherwise, if ORIGFN is the function that creates windows of a class (e.g. SNAPW), then a MODERNWINDOWFN should be provided to create such windows (by calling (PACK* MODERN-ORIG- ORIGFN)). The definition of MODERNWINDOWFN replaces the original definition of ORIGFN. + +If the flag ANYWHERE is non-NIL, especially for windows without a title bar, then the moving behavior is triggered by a click anywhere in the window (except the corners). + +Because this works by redefining existing functions, it is important that the MODERNIZE package be loaded AFTER Tedit and Sedit, if those are not already in the sysout. And it should be called to upgrade the proper functions for other window classes that might later be added. + +Provided these capabilities are already loaded, the following window classes are "modernized" when MODERNIZE is loaded are: + + TEDIT + SEDIT + INSPECTOR + SNAP + DEBUGGER + EXEC + TABLEBROWSER + FILEBROWSER + FREEMENU + GRAPHER + PROMPTWINDOW + +If it is not known or it is inconvenient to systematically upgrade a button function or a window-creation function, the new behavior can be provided after a particular window has been created, by invoking + +(MODERNWINDOW WINDOW ANYWHERE) + +This saves the windows existing BUTTONEVENTFN as a window property PREMODERN-BUTTONEVENTFN, and installs a simple stub function in its place. + +If things go awry: + +(UNMODERN.SETUP ORIGFN) is provided to restore the original behavior for windows whose buttonevent function is ORIGIN. + +(UNMODERNWINDOW WINDOW) restores a modernized window (via MACWINDOW) to its original state. + +Known issue: Clicking at the bottom-right corner of Tedit windows sometimes doesn't catch the new behavior--there seems to be a conflict with Tedit's window-splitting conventions. Clicking a little further into the window seems more reliable. + + + diff --git a/lispusers/WHEELSCROLL b/lispusers/WHEELSCROLL index baf31632..48007aae 100644 --- a/lispusers/WHEELSCROLL +++ b/lispusers/WHEELSCROLL @@ -1 +1 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "21-Feb-2021 09:39:06"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;42 6734 changes to%: (VARS WHEELSCROLLCOMS) (FNS WHEELSCROLL) previous date%: "20-Feb-2021 17:34:35" {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;39) (PRETTYCOMPRINT WHEELSCROLLCOMS) (RPAQQ WHEELSCROLLCOMS [(FNS ENABLEWHEELSCROLL WHEELSCROLL WHEELSCROLL.DOIT INSTALL-WHEELSCROLL LISPINTERRUPTS.WHEELSCROLL) [VARS (WHEELSCROLLINTERRUPTS '((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA) T) (521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA)) T] (GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS) (INITVARS (WHEELSCROLLDELTA 20) (WHEELSCROLLSETTLETIME 50) (\WHEELSCROLLINPROGRESS NIL)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T]) (DEFINEQ (ENABLEWHEELSCROLL [LAMBDA (ON) (* ; "Edited 15-Feb-2021 18:17 by rmk:") (* ;; "So we can toggle this scrolling, for experimentation.") (IF ON THEN [KEYACTION 'PAD1 '((520 520) . IGNORE] [KEYACTION 'PAD2 '((521 521) . IGNORE] ELSE (KEYACTION 'PAD1 '(IGNORE . IGNORE)) (KEYACTION 'PAD2 '(IGNORE . IGNORE]) (WHEELSCROLL [LAMBDA (DIRECTION DELTA) (* ; "Edited 21-Feb-2021 09:38 by rmk:") (* ;; "The wheel may accidentally turn (giving the interrupt) when the users intention is simply to push the middle button. And there may be another accidental turn (also giving an interrupt) when the user is releasing the middle button. We don't yet have a good solution to this problem. (This is not an issue with a trackpad)") (* ;; "") (CL:WHEN (MOUSESTATE UP) (* ;  "Ignore interrupt if a button is down") [LET ((W (WHICHW))) (* Unsuccessful a ttempt to suppress scroll if middlebutton comes down within  the setetle time (NOT (UNTILMOUSESTATE (ONLY MIDDLE) WHEELSCROLLSETTLETIME))) (CL:WHEN W (* ;; "We scroll only if the window has a scrollfn. Our behavior is thus different from a direct call to SCROLLW, which defaults to SCROLLBYREPAINTFN in that case, but conforms to what happens with IN/SCROLL/BAR? and SCROLL.HANDLER in WINDOWSCROLL. Menus and scrollbars typically do not have scrollfns, so this suppresses otherwise funky behavior. ") (IF (WINDOWPROP W 'SCROLLFN) THEN [PROCESS.EVAL (FIND.PROCESS 'MOUSE) (CL:IF (EQ DIRECTION 'VERTICAL) `(WHEELSCROLL.DOIT ,(KWOTE W) 0 ,DELTA) `(WHEELSCROLL.DOIT ,(KWOTE W) ,DELTA 0))] ELSEIF (EQ DIRECTION 'VERTICAL) THEN (* ;; "We are in a pop-up scrollbar. This moves the cursor there, the user has to click to scroll the main window.") (CL:WHEN (WINDOWPROP W 'VERTICALSCROLLBARFOR) (\CURSORPOSITION LASTMOUSEX (IPLUS LASTMOUSEY DELTA)) (GETMOUSESTATE)) ELSEIF (EQ DIRECTION 'HORIZONTAL) THEN (CL:WHEN (WINDOWPROP W 'HORIZONTALSCROLLBARFOR) (\CURSORPOSITION (IPLUS DELTA LASTMOUSEX) LASTMOUSEY) (GETMOUSESTATE))))])]) (WHEELSCROLL.DOIT [LAMBDA (WINDOW DX DY) (* ; "Edited 20-Feb-2021 17:34 by rmk:") (* ;; "This does the actual wheel scrolling, runing in the mouse process.") (* ;; "There have been instances where the window gets garbled as the wheel moves. The hypothesis is that this is because the wheel moves so fast that another scroll starts before a previous one completes.") (* ;; "The global variable \WHEELSCROLLINPROGRESS is set to prevent that interference.") (CL:UNLESS \WHEELSCROLLINPROGRESS (RESETVAR \WHEELSCROLLINPROGRESS T (SCROLLW WINDOW DX DY)))]) (INSTALL-WHEELSCROLL [LAMBDA NIL (* ; "Edited 17-Feb-2021 11:53 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG) (MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS)) (FOR I IN WHEELSCROLLINTERRUPTS DO (INTERRUPTCHAR (CAR I) (CADR I) (CADDR I)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts") (TEDIT.SETFUNCTION (CAR I) `[LAMBDA NIL ,(CADR I] TEDIT.READTABLE))]) (LISPINTERRUPTS.WHEELSCROLL [LAMBDA NIL (* ; "Edited 17-Feb-2021 11:09 by rmk:") (* ;; "So wheelscroll interrupts will be installed in every process") (APPEND WHEELSCROLLINTERRUPTS (LISPINTERRUPTS.WSORIG]) ) (RPAQQ WHEELSCROLLINTERRUPTS ((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA) T) (521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA)) T))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS) ) (RPAQ? WHEELSCROLLDELTA 20) (RPAQ? WHEELSCROLLSETTLETIME 50) (RPAQ? \WHEELSCROLLINPROGRESS NIL) (DECLARE%: DONTEVAL@LOAD DOCOPY (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (1187 6142 (ENABLEWHEELSCROLL 1197 . 1622) (WHEELSCROLL 1624 . 4160) (WHEELSCROLL.DOIT 4162 . 4798) (INSTALL-WHEELSCROLL 4800 . 5863) (LISPINTERRUPTS.WHEELSCROLL 5865 . 6140))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "22-Feb-2021 09:47:46"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;43 7259 changes to%: (VARS WHEELSCROLLCOMS) (FNS ENABLEWHEELSCROLL) previous date%: "21-Feb-2021 09:39:06" {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;42) (PRETTYCOMPRINT WHEELSCROLLCOMS) (RPAQQ WHEELSCROLLCOMS [(FNS ENABLEWHEELSCROLL WHEELSCROLL WHEELSCROLL.DOIT INSTALL-WHEELSCROLL LISPINTERRUPTS.WHEELSCROLL) [VARS (WHEELSCROLLINTERRUPTS '((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA) T) (521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA)) T) (522 (WHEELSCROLL 'HORIZONTAL (IMINUS WHEELSCROLLDELTA) T)) (523 (WHEELSCROLL 'HORIZONTAL WHEELSCROLLDELTA T] (GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS) (INITVARS (WHEELSCROLLDELTA 20) (WHEELSCROLLSETTLETIME 50) (\WHEELSCROLLINPROGRESS NIL)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T]) (DEFINEQ (ENABLEWHEELSCROLL [LAMBDA (ON) (* ; "Edited 22-Feb-2021 09:47 by rmk:") (* ;; "So we can toggle this scrolling, for experimentation.") (IF ON THEN [KEYACTION 'PAD1 '((520 520) . IGNORE] [KEYACTION 'PAD2 '((521 521) . IGNORE] [KEYACTION 'PAD4 '((522 522) . IGNORE] [KEYACTION 'PAD5 '((523 523) . IGNORE] ELSE (KEYACTION 'PAD1 '(IGNORE . IGNORE)) (KEYACTION 'PAD2 '(IGNORE . IGNORE)) (KEYACTION 'PAD4 '(IGNORE . IGNORE)) (KEYACTION 'PAD5 '(IGNORE . IGNORE]) (WHEELSCROLL [LAMBDA (DIRECTION DELTA) (* ; "Edited 21-Feb-2021 09:38 by rmk:") (* ;; "The wheel may accidentally turn (giving the interrupt) when the users intention is simply to push the middle button. And there may be another accidental turn (also giving an interrupt) when the user is releasing the middle button. We don't yet have a good solution to this problem. (This is not an issue with a trackpad)") (* ;; "") (CL:WHEN (MOUSESTATE UP) (* ;  "Ignore interrupt if a button is down") [LET ((W (WHICHW))) (* Unsuccessful a ttempt to suppress scroll if middlebutton comes down within  the setetle time (NOT (UNTILMOUSESTATE (ONLY MIDDLE) WHEELSCROLLSETTLETIME))) (CL:WHEN W (* ;; "We scroll only if the window has a scrollfn. Our behavior is thus different from a direct call to SCROLLW, which defaults to SCROLLBYREPAINTFN in that case, but conforms to what happens with IN/SCROLL/BAR? and SCROLL.HANDLER in WINDOWSCROLL. Menus and scrollbars typically do not have scrollfns, so this suppresses otherwise funky behavior. ") (IF (WINDOWPROP W 'SCROLLFN) THEN [PROCESS.EVAL (FIND.PROCESS 'MOUSE) (CL:IF (EQ DIRECTION 'VERTICAL) `(WHEELSCROLL.DOIT ,(KWOTE W) 0 ,DELTA) `(WHEELSCROLL.DOIT ,(KWOTE W) ,DELTA 0))] ELSEIF (EQ DIRECTION 'VERTICAL) THEN (* ;; "We are in a pop-up scrollbar. This moves the cursor there, the user has to click to scroll the main window.") (CL:WHEN (WINDOWPROP W 'VERTICALSCROLLBARFOR) (\CURSORPOSITION LASTMOUSEX (IPLUS LASTMOUSEY DELTA)) (GETMOUSESTATE)) ELSEIF (EQ DIRECTION 'HORIZONTAL) THEN (CL:WHEN (WINDOWPROP W 'HORIZONTALSCROLLBARFOR) (\CURSORPOSITION (IPLUS DELTA LASTMOUSEX) LASTMOUSEY) (GETMOUSESTATE))))])]) (WHEELSCROLL.DOIT [LAMBDA (WINDOW DX DY) (* ; "Edited 20-Feb-2021 17:34 by rmk:") (* ;; "This does the actual wheel scrolling, runing in the mouse process.") (* ;; "There have been instances where the window gets garbled as the wheel moves. The hypothesis is that this is because the wheel moves so fast that another scroll starts before a previous one completes.") (* ;; "The global variable \WHEELSCROLLINPROGRESS is set to prevent that interference.") (CL:UNLESS \WHEELSCROLLINPROGRESS (RESETVAR \WHEELSCROLLINPROGRESS T (SCROLLW WINDOW DX DY)))]) (INSTALL-WHEELSCROLL [LAMBDA NIL (* ; "Edited 17-Feb-2021 11:53 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG) (MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS)) (FOR I IN WHEELSCROLLINTERRUPTS DO (INTERRUPTCHAR (CAR I) (CADR I) (CADDR I)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts") (TEDIT.SETFUNCTION (CAR I) `[LAMBDA NIL ,(CADR I] TEDIT.READTABLE))]) (LISPINTERRUPTS.WHEELSCROLL [LAMBDA NIL (* ; "Edited 17-Feb-2021 11:09 by rmk:") (* ;; "So wheelscroll interrupts will be installed in every process") (APPEND WHEELSCROLLINTERRUPTS (LISPINTERRUPTS.WSORIG]) ) (RPAQQ WHEELSCROLLINTERRUPTS ((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA) T) (521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA)) T) (522 (WHEELSCROLL 'HORIZONTAL (IMINUS WHEELSCROLLDELTA) T)) (523 (WHEELSCROLL 'HORIZONTAL WHEELSCROLLDELTA T)))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS) ) (RPAQ? WHEELSCROLLDELTA 20) (RPAQ? WHEELSCROLLSETTLETIME 50) (RPAQ? \WHEELSCROLLINPROGRESS NIL) (DECLARE%: DONTEVAL@LOAD DOCOPY (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (1432 6591 (ENABLEWHEELSCROLL 1442 . 2071) (WHEELSCROLL 2073 . 4609) (WHEELSCROLL.DOIT 4611 . 5247) (INSTALL-WHEELSCROLL 5249 . 6312) (LISPINTERRUPTS.WHEELSCROLL 6314 . 6589))))) STOP diff --git a/run-medley b/run-medley index beac3c66..609fd874 100755 --- a/run-medley +++ b/run-medley @@ -59,8 +59,15 @@ while [ "$#" -ne 0 ]; do shift ;; "--dimensions" | "-dimensions") - geometry="-g $2" - screensize="-sc $2" + sw=`expr "$2" : "\([0-9]*\)x[0-9]*$"` + sh=`expr "$2" : "[0-9]*x\([0-9]*\)$"` + if [ -n "$sw" -a -n "$sh" ] ; then + sw=$(( (31+$sw)/32*32 )) + gw=$(( 22+$sw )) + gh=$(( 22+$sh )) + geometry="-g ${gw}x${gh}" + screensize="-sc ${sw}x${sh}" + fi shift ;; "--geometry" | "-geometry" | "-g") diff --git a/sources/LOADUP-FULL b/sources/LOADUP-FULL index e1c7d3ec..4817a4d3 100644 --- a/sources/LOADUP-FULL +++ b/sources/LOADUP-FULL @@ -1 +1 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "14-Feb-2021 10:08:45" {DSK}larry>ilisp>medley>sources>LOADUP-FULL.;7 5949 changes to%: (FNS MAKEFULLSYSOUT) previous date%: "13-Feb-2021 23:47:35" {DSK}larry>ilisp>medley>sources>LOADUP-FULL.;6) (PRETTYCOMPRINT LOADUP-FULLCOMS) (RPAQQ LOADUP-FULLCOMS ((COMMANDS "cd" "pwd" "ls") (FNS LOADFULLFONTS MAKEFULLSYSOUT FIXMETA) (P (FIXMETA)) (GLOBALVARS MISSINGDISPLAYFONTCOERCIONS MISSINGCHARSETDISPLAYFONTCOERCIONS) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY (P (MAKEFULLSYSOUT T))) (PROP FILETYPE))) (DEFCOMMAND "cd" (DIR) (/CNDIR DIR)) (DEFCOMMAND "pwd" NIL (DIRECTORYNAME T)) (DEFCOMMAND "ls" (FIRST . REST) (DODIR (CONS FIRST REST))) (DEFINEQ (LOADFULLFONTS [LAMBDA NIL (* ; "Edited 13-Feb-2021 22:51 by larry") (* ;; " Don't do Interpress. Do character set 0 and the symbol character sets 41Q, 42Q, 356Q, 357Q and extended and accented Latin 43Q and 361Q") (PRINTOUT T "Loading FULL fonts..." T) (SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT STRIKE)) (SETQ *POSTSCRIPT-FILE-TYPE* 'TEXT) (RESETVARS ((MISSINGDISPLAYFONTCOERCIONS NIL) (MISSINGCHARSETDISPLAYFONTCOERCIONS NIL)) (* ;  "Don't let the font loader substitute just because a server went catatonic on us") (for FAMILY in '(CLASSIC MODERN TERMINAL) do (PRINTOUT T " Loading " FAMILY " ") [for SIZE in '(8 10 12) do (PRINTOUT T SIZE " ") (for FACE in '(MRR BRR MIR) do (for CSET in '(0 33 34 35 238 239 241) do (NLSETQ (FONTCREATE FAMILY SIZE FACE NIL 'DISPLAY NIL CSET] (PRINTOUT T T)) (PRINTOUT T " Loading postscript fonts" T) (for F in (FILDIR (CONCAT (CAR POSTSCRIPTFONTDIRECTORIES) ">c0>*.*")) do (PSCFONT.READFONT F)) (PRINTOUT T "FULL fonts loaded" T]) (MAKEFULLSYSOUT [LAMBDA (DOIT) (* ; "Edited 14-Feb-2021 10:08 by larry") (* ; "Edited 14-May-2018 15:01 by kaplan") (* ; "Edited 28-Sep-2020 12:35 by rmk:") (* ; "Edited 17-Apr-2018 08:41 by ") (* ; "Edited 21-Apr-2018 07:27 by rmk:") (* ; "Edited 23-Feb-94 15:04 by bvm") (CLRPROMPT) (SETQ MAKESYSFILENAME (CONCAT (MEDLEYDIR "loadups") "full.sysout")) (SETQ MAKESYSNAME (CONCAT "Medley from Interlisp.org of " (DATE))) (DRIBBLE (PACKFILENAME 'EXTENSION "dribble" 'BODY MAKESYSFILENAME)) (* ;; "BKSYSBUF stops page holding ") (PRINTOUT T T "Full loadup started at " (DATE) " while connected to " (DIRECTORYNAME T) T T) (BKSYSBUF " ") (SETQ DEFAULTFILETYPE 'BINARY) (* ;  "These prevent bits from being lost due to lack of knowledge") (DREMOVE (ASSOC NIL DEFAULTFILETYPELIST) DEFAULTFILETYPELIST) (push DEFAULTFILETYPELIST '(TXT . TEXT) '(TEXT . TEXT) '(TEX . TEXT) '(HTML . TEXT) '(HTM . TEXT)) (MEDLEY-INIT-VARS) (SETQ LOADUPDIRECTORIES DIRECTORIES) (LOADUP '(POSTSCRIPTSTREAM)) (* ; " to get PSCFONT.READFONT") (LOADFULLFONTS) (LISTPUT IDLE.PROFILE 'TIMEOUT 0) (SETQQ *DEFAULT-CLEANUP-COMPILER* BCOMPL) (LOADUP '(CHAT PRESS INTERPRESS TEDIT HRULE TEDITCHAT READNUMBER EDITBITMAP FILEBROWSER THINFILES GRAPHER SPY WHERE-IS COPYFILES MSANALYZE MSPARSE MASTERSCOPE UNIXPRINT UNICODE ISO8859IO HELPSYS DINFO CLIPBOARD MACINTERFACE PRETTYFILEINDEX WHO-LINE UNIXCOMM UNIXCHAT)) (SETQ *WHO-LINE-ANCHOR* '(:CENTER :TOP)) (* ;; "Turn off who-line until after the user has greeted") (CL:WHEN (WINDOWP *WHO-LINE*) (CLOSEW *WHO-LINE*)) [SETQ POSTGREETFORMS (APPEND POSTGREETFORMS '((INSTALL-WHO-LINE-OPTIONS] (LISTPUT IDLE.PROFILE 'TIMEOUT 20) (SETTOPVAL 'INITIALS NIL) (ENDLOADUP) (COND ((WINDOWP LOGOW) (CLOSEW LOGOW))) (DREMOVE (ASSOC 'LOGOW AFTERMAKESYSFORMS) AFTERMAKESYSFORMS) (push AFTERMAKESYSFORMS '(CLRPROMPT) '(MEDLEY-INIT-VARS)) (* ;; "Set up for making the sysout, if we made it this far.") (CL:WHEN DOIT (PRINTOUT T "Creating FULL sysout on " MAKESYSFILENAME T) (BKSYSBUF (CONCAT "(IL:MAKESYS %"" MAKESYSFILENAME "%" %"Medley " " Full Sysout%")" " (IL:LOGOUT T)"))) (DRIBBLE]) (FIXMETA [LAMBDA NIL (* ;  "Edited 25-Jun-2017 17:12 by rmk:") (KEYACTION 'BLANK-TOP '(METADOWN . METAUP) \CURRENTKEYACTION) (KEYACTION 'BLANK-TOP '(METADOWN . METAUP]) ) (FIXMETA) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MISSINGDISPLAYFONTCOERCIONS MISSINGCHARSETDISPLAYFONTCOERCIONS) ) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY (MAKEFULLSYSOUT T) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (814 5721 (LOADFULLFONTS 824 . 2412) (MAKEFULLSYSOUT 2414 . 5410) (FIXMETA 5412 . 5719)) ))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "22-Feb-2021 16:56:12"  {DSK}kaplan>Local>medley3.5>git-medley>sources>LOADUP-FULL.;2 8011 changes to%: (FNS MAKEFULLSYSOUT) previous date%: " 6-Feb-2021 15:41:34" {DSK}kaplan>Local>medley3.5>git-medley>sources>LOADUP-FULL.;1) (PRETTYCOMPRINT LOADUP-FULLCOMS) (RPAQQ LOADUP-FULLCOMS ((COMMANDS "cd" "pwd" "ls") (FNS LOADFULLFONTS MAKEFULLSYSOUT FIXMETA) (P (FIXMETA)) (VARS (WRITEFULLSYSOUTFLAG T)) (GLOBALVARS MISSINGDISPLAYFONTCOERCIONS MISSINGCHARSETDISPLAYFONTCOERCIONS) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY (P (MAKEFULLSYSOUT))) (PROP FILETYPE))) (DEFCOMMAND "cd" (DIR) (/CNDIR DIR)) (DEFCOMMAND "pwd" NIL (DIRECTORYNAME T)) (DEFCOMMAND "ls" (FIRST . REST) (DODIR (CONS FIRST REST))) (DEFINEQ (LOADFULLFONTS [LAMBDA (ROOTDIRECTORY) (* ;  "Edited 11-Aug-2020 17:53 by rmk:") (* ;; " Don't do Interpress. Do character set 0 and the symbol character sets 41Q, 42Q, 356Q, 357Q and extended and accented Latin 43Q and 361Q") (PRINTOUT T "Loading FULL fonts..." T) (SETQ DISPLAYFONTDIRECTORIES (LIST (PACK* ROOTDIRECTORY "/fonts/displayfonts") (PACK* ROOTDIRECTORY "/fonts/altofonts"))) (* (SETQ INTERPRESSFONTDIRECTORIES  (CONS (PACK* ROOTDIRECTORY  "/fonts/ipfonts")))) (SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT STRIKE)) (SETQ POSTSCRIPTFONTDIRECTORIES (CONS (PACK* ROOTDIRECTORY "/fonts/postscriptfonts"))) (SETQ *POSTSCRIPT-FILE-TYPE* 'TEXT) (RESETVARS ((MISSINGDISPLAYFONTCOERCIONS NIL) (MISSINGCHARSETDISPLAYFONTCOERCIONS NIL)) (* ;  "Don't let the font loader substitute just because a server went catatonic on us") (for FAMILY in '(CLASSIC MODERN TERMINAL) do (PRINTOUT T " Loading " FAMILY " ") [for SIZE in '(8 10 12) do (PRINTOUT T SIZE " ") (for FACE in '(MRR BRR MIR) do (* ;; "No need for Interpress") (* (NLSETQ (FONTCREATE FAMILY SIZE  FACE NIL (QUOTE INTERPRESS) NIL 0))) (for CSET in '(0 33 34 35 238 239 241) do (NLSETQ (FONTCREATE FAMILY SIZE FACE NIL 'DISPLAY NIL CSET] (PRINTOUT T T)) (PRINTOUT T " Loading postscript fonts" T) (for F in (FILDIR (CONCAT (CAR POSTSCRIPTFONTDIRECTORIES) ">c0>*.*")) do (PSCFONT.READFONT F)) (PRINTOUT T "FULL fonts loaded" T]) (MAKEFULLSYSOUT [LAMBDA NIL (* ;  "Edited 5-Dec-2020 20:07 by larry") (* ;  "Edited 14-May-2018 15:01 by kaplan") (* ;  "Edited 22-Feb-2021 16:56 by rmk:") (* ; "Edited 17-Apr-2018 08:41 by ") (* ;  "Edited 21-Apr-2018 07:27 by rmk:") (* ; "Edited 23-Feb-94 15:04 by bvm") (CLRPROMPT) (CNDIR (UNIX-GETENV "LOADUPDIR")) (LET ((ROOTDIRECTORY (MEDLEYDIR))) (SETQ MAKESYSFILENAME (CONCAT (MEDLEYDIR "loadups") "xfull35.sysout")) (DRIBBLE (PACKFILENAME 'EXTENSION 'DRIBBLE 'BODY MAKESYSFILENAME)) (* ;; "BKSYSBUF stops page holding ") (PRINTOUT T T "Full loadup started at " (DATE) " while connected to " (DIRECTORYNAME T) T T) (BKSYSBUF " ") (SETQ DEFAULTFILETYPE 'BINARY) (* ;  "These prevent bits from being lost due to lack of knowledge") (DREMOVE (ASSOC NIL DEFAULTFILETYPELIST) DEFAULTFILETYPELIST) (* (SETQ *UPPER-CASE-FILE-NAMES* NIL)) (SETQ MAKESYSNAME :MEDLEY3.5) (push DEFAULTFILETYPELIST '(TXT . TEXT) '(TEXT . TEXT) '(TEX . TEXT) '(HTML . TEXT) '(HTM . TEXT)) (MEDLEY-INIT-VARS) (SETQ LOADUPDIRECTORIES DIRECTORIES) (LOADUP '(POSTSCRIPTSTREAM)) (* ; " to get PSCFONT.READFONT") (LOADFULLFONTS (MEDLEYDIR)) (LISTPUT IDLE.PROFILE 'TIMEOUT 0) (SETQQ *DEFAULT-CLEANUP-COMPILER* BCOMPL) (LOADUP '(CHAT TEDIT HRULE TEDITCHAT READNUMBER EDITBITMAP FILEBROWSER THINFILES GRAPHER SPY WHERE-IS COPYFILES MSANALYZE MSPARSE MASTERSCOPE UNIXPRINT UNICODE ISO8859IO HELPSYS DINFO CLIPBOARD MODERNIZE)) (FILESLOAD (SYSLOAD) PRETTYFILEINDEX WHO-LINE) (SETQ *WHO-LINE-ANCHOR* '(:CENTER :TOP)) (* ;; "Turn off who-line until after the user has greeted") (CL:WHEN (WINDOWP *WHO-LINE*) (CLOSEW *WHO-LINE*)) [SETQ POSTGREETFORMS (APPEND POSTGREETFORMS '((INSTALL-WHO-LINE-OPTIONS] (FILESLOAD (SYSLOAD) UNIXCOMM UNIXCHAT UNIXTELNET) (FILESLOAD (SYSLOAD) SETDEFAULTPRINTER) (FILESLOAD (SYSLOAD) LOADPATCHES) (\DAYTIME0 \LASTUSERACTION) (LISTPUT IDLE.PROFILE 'TIMEOUT 20) (for TYPE in FILEPKTYPES do (FILEPKGCHANGES TYPE NIL)) (SETTOPVAL 'INITIALS NIL) (PROMPTPRINT "About to end loadup") (PRINTOUT T "About to end loadup" T) (* ;; "From SYNCLISPFILES") (ENDLOADUP) (COND ((WINDOWP LOGOW) (CLOSEW LOGOW))) (DREMOVE (ASSOC 'LOGOW AFTERMAKESYSFORMS) AFTERMAKESYSFORMS) (push AFTERMAKESYSFORMS '(CLRPROMPT) '(MEDLEY-INIT-VARS)) (* ;; "Set up for making the sysout, if we made it this far.") (CL:WHEN WRITEFULLSYSOUTFLAG (PRINTOUT T "Creating FULL sysout on " MAKESYSFILENAME T) (BKSYSBUF (CONCAT "(IL:MAKESYS %"" MAKESYSFILENAME "%" %"Medley " (MEDLEYVERSION) " Full Sysout%")"))) (DRIBBLE]) (FIXMETA [LAMBDA NIL (* ;  "Edited 25-Jun-2017 17:12 by rmk:") (KEYACTION 'BLANK-TOP '(METADOWN . METAUP) \CURRENTKEYACTION) (KEYACTION 'BLANK-TOP '(METADOWN . METAUP]) ) (FIXMETA) (RPAQQ WRITEFULLSYSOUTFLAG T) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MISSINGDISPLAYFONTCOERCIONS MISSINGCHARSETDISPLAYFONTCOERCIONS) ) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY (MAKEFULLSYSOUT) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (885 7750 (LOADFULLFONTS 895 . 3399) (MAKEFULLSYSOUT 3401 . 7439) (FIXMETA 7441 . 7748)) ))) STOP diff --git a/sources/TWODINSPECTOR.LCOM.~2~ b/sources/TWODINSPECTOR.LCOM.~2~ deleted file mode 100644 index e5f3facc..00000000 Binary files a/sources/TWODINSPECTOR.LCOM.~2~ and /dev/null differ