github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-01-12 00:42:56 +00:00
Code Issues Projects Releases Wiki Activity

The setting to NEVER wasn't suppressing asking. (#1550)

Browse Source 
The issue was incorrectly getting the ROOTFILENAME as where to attach the COPYRIGHT property.
This commit is contained in:
Matt Heffron 2024-02-24 19:14:31 -08:00 committed by GitHub
parent de7a1e1deb
commit f8521c612e
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
2 changed files with 66 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

125
library/DATABASEFNS
View File

@ -1,13 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "19-Feb-2024 16:29:44" {LIB}DATABASEFNS.;15 17624
(FILECREATED "20-Feb-2024 23:45:56" {DSK}<mnt>e>Interlisp>medley>library>DATABASEFNS.;4 18445
:EDIT-BY "mth"
:CHANGES-TO (VARS DATABASEFNSCOMS)
(FNS DUMPDB)
:CHANGES-TO (FNS DUMPDB)
:PREVIOUS-DATE "27-Oct-2021 10:55:18" {DSK}<mnt>e>Interlisp>medley>library>DATABASEFNS.;1)
:PREVIOUS-DATE "19-Feb-2024 16:29:44" {DSK}<mnt>e>Interlisp>medley>library>DATABASEFNS.;1)
(* ; "
@ -165,7 +164,8 @@ Copyright (c) 1986, 1990-1993, 2024 by Xerox Corporation.
(DEFINEQ
(DUMPDB
[LAMBDA (FILE PROPFLG) (* ; "Edited 7-Feb-2024 18:26 by mth")
[LAMBDA (FILE PROPFLG) (* ; "Edited 20-Feb-2024 23:45 by mth")
(* ; "Edited 7-Feb-2024 18:26 by mth")
(* ; "Edited 27-Oct-2021 10:51 by larry")
(* ; "Edited 24-Oct-2021 16:24 by rmk:")
@ -173,69 +173,76 @@ Copyright (c) 1986, 1990-1993, 2024 by Xerox Corporation.
(* ;; "The FILE check is because MAKEFILE returns a list when it doesn't understand the options")
(DECLARE (GLOBALVARS MSFILETABLE SAVEDBFLG)
(SPECVARS DEFAULTDATABASECOPYRIGHTOWNER COPYRIGHTFLG DEFAULTCOPYRIGHTOWNER))
(DECLARE (GLOBALVARS MSFILETABLE SAVEDBFLG COPYRIGHTFLG DEFAULTCOPYRIGHTOWNER)
(SPECVARS DEFAULTDATABASECOPYRIGHTOWNER))
(CL:WHEN (AND FILE (OR (LITATOM FILE)
(STRINGP FILE)))
(PROG (DBFILE DBFN FLCPR (FL (NAMEFIELD FILE))
(FNS (FILEFNSLST FILE))
(COPYRIGHTFLG COPYRIGHTFLG)
(DEFAULTCOPYRIGHTOWNER DEFAULTCOPYRIGHTOWNER))
(SETQ DBFN (PACKFILENAME 'EXTENSION 'DATABASE 'VERSION NIL 'BODY FILE))
(CL:UNLESS (OR (EQ COPYRIGHTFLG 'NEVER)
(NULL DEFAULTDATABASECOPYRIGHTOWNER)
(GETPROP DBFN 'COPYRIGHT))
(SELECTQ DEFAULTDATABASECOPYRIGHTOWNER
((NONE NEVER)
(* ;; "Set the COPYRIGHT to NONE (I.e., never mention it again.)")
(LET ((SAVEDCOPYRIGHTFLG COPYRIGHTFLG)
(SAVEDDEFAULTCOPYRIGHTOWNER DEFAULTCOPYRIGHTOWNER))
(CL:UNWIND-PROTECT
(PROG (DBFILE DBFN DBROOTFN FLCPR (FL (NAMEFIELD FILE))
(FNS (FILEFNSLST FILE)))
(SETQ DBFN (PACKFILENAME 'EXTENSION 'DATABASE 'VERSION NIL 'BODY FILE))
(SETQ DBROOTFN (ROOTFILENAME DBFN))
(CL:UNLESS (OR (EQ COPYRIGHTFLG 'NEVER)
(NULL DEFAULTDATABASECOPYRIGHTOWNER)
(GETPROP DBROOTFN 'COPYRIGHT))
(SELECTQ DEFAULTDATABASECOPYRIGHTOWNER
((NONE NEVER)
(* ;;
 "Set the COPYRIGHT to NONE (I.e., never mention it again.)")
(/PUT DBFN 'COPYRIGHT (LIST 'NONE)))
(SAME
(* ;;
(/PUT DBROOTFN 'COPYRIGHT (LIST 'NONE)))
(SAME
(* ;;
 "Same as the source file. If it doesn't have one, then just normal handling")
(CL:WHEN (SETQ FLCPR (GETPROP FL 'COPYRIGHT))
(/PUT DBFN 'COPYRIGHT (LIST (CAR FLCPR)))))
(DEFAULT
(* ;; "Use the general default for copyright")
(CL:WHEN (SETQ FLCPR (GETPROP FL 'COPYRIGHT))
(/PUT DBROOTFN 'COPYRIGHT (LIST (CAR FLCPR)))))
(DEFAULT
(* ;; "Use the general default for copyright")
(SETQ COPYRIGHTFLG 'DEFAULT))
(PROGN (SETQ COPYRIGHTFLG 'DEFAULT)
(SETQ COPYRIGHTFLG 'DEFAULT))
(PROGN (SETQ COPYRIGHTFLG 'DEFAULT)
(* ;;
(* ;;
 "Hopefully, DEFAULTDATABASECOPYRIGHTOWNER is one of the COPYRIGHTOWNERS keys")
(SETQ DEFAULTCOPYRIGHTOWNER DEFAULTDATABASECOPYRIGHTOWNER))))
(COND
(FNS)
((AND MSFILETABLE (TESTTABLE FL (CADR MSFILETABLE)))
(SETQ DEFAULTCOPYRIGHTOWNER DEFAULTDATABASECOPYRIGHTOWNER))))
(COND
(FNS)
((AND MSFILETABLE (TESTTABLE FL (CADR MSFILETABLE)))
(* ;
 "Always dump if this is a known file")
(SETQ PROPFLG NIL))
(T (COND
(PROPFLG (/REMPROP FL 'DATABASE))
(T (printout T T FILE " has no functions." T)))
(RETURN)))
(CL:WHEN [OR (NULL PROPFLG)
(EQ (GETPROP FL 'DATABASE)
'YES)
(EQ SAVEDBFLG 'YES)
(AND MSFILETABLE (TESTTABLE FL (CADR MSFILETABLE]
(CL:WHEN MSFILETABLE
[STORETABLE FL MSFILETABLE (CAR (GETPROP FL 'FILEDATES])
[SETQ DBFILE (PRETTYDEF NIL DBFN
`((P (PROGN (PRIN1 "Use LOADDB to load database files!" T)
(ERROR!)))
(E [PRINT (CAR (GETPROP ',FILE 'FILEDATES]
(DUMPDATABASE ',FNS]
[COND
(PROPFLG (PRINT (FULLNAME DBFILE)
T))
(T (/PUT FL 'DATABASEFILENAME DBFILE) (* ;
(SETQ PROPFLG NIL))
(T (COND
(PROPFLG (/REMPROP FL 'DATABASE))
(T (printout T T FILE " has no functions." T)))
(RETURN)))
(CL:WHEN [OR (NULL PROPFLG)
(EQ (GETPROP FL 'DATABASE)
'YES)
(EQ SAVEDBFLG 'YES)
(AND MSFILETABLE (TESTTABLE FL (CADR MSFILETABLE]
(CL:WHEN MSFILETABLE
[STORETABLE FL MSFILETABLE (CAR (GETPROP FL 'FILEDATES])
[SETQ DBFILE
(PRETTYDEF NIL DBFN
`((P (PROGN (PRIN1 "Use LOADDB to load database files!" T)
(ERROR!)))
(E [PRINT (CAR (GETPROP ',FILE 'FILEDATES]
(DUMPDATABASE ',FNS]
[COND
(PROPFLG (PRINT (FULLNAME DBFILE)
T))
(T (/PUT FL 'DATABASEFILENAME DBFILE)
(* ;
 "Remember that we have this file valid already.")
(/PUT FL 'DATABASE 'YES] (* ;
 "Take future note of the databae on a user call")
(RETURN DBFILE))))])
(/PUT FL 'DATABASE 'YES] (* ;
 "Take future note of the database on a user call")
(RETURN DBFILE))))
(SETQ COPYRIGHTFLG SAVEDCOPYRIGHTFLG)
(SETQ DEFAULTCOPYRIGHTOWNER SAVEDDEFAULTCOPYRIGHTOWNER)))])
(LOADDB
[LAMBDA (FILE ASKFLAG) (* ; "Edited 24-Oct-2021 17:44 by rmk:")
@ -370,7 +377,7 @@ Copyright (c) 1986, 1990-1993, 2024 by Xerox Corporation.
)
(PUTPROPS DATABASEFNS COPYRIGHT ("Xerox Corporation" 1986 1990 1991 1992 1993 2024))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1778 6803 (DBFILE 1788 . 3433) (DBFILE1 3435 . 4945) (DBFILE2 4947 . 6169) (LOAD 6171
. 6401) (LOADFROM 6403 . 6591) (MAKEFILE 6593 . 6801)) (6859 17017 (DUMPDB 6869 . 11052) (LOADDB
11054 . 15929) (MAKEDB 15931 . 17015)))))
(FILEMAP (NIL (1768 6793 (DBFILE 1778 . 3423) (DBFILE1 3425 . 4935) (DBFILE2 4937 . 6159) (LOAD 6161
. 6391) (LOADFROM 6393 . 6581) (MAKEFILE 6583 . 6791)) (6849 17838 (DUMPDB 6859 . 11873) (LOADDB
11875 . 16750) (MAKEDB 16752 . 17836)))))
STOP

BIN
library/DATABASEFNS.LCOM
View File

Binary file not shown.