github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-03-02 18:14:44 +00:00
Code Issues Projects Releases Wiki Activity

WINDOWOBJ: READIMAGEOBJ doesn't ask for permission (#1449)

Browse Source 
If the image object is on a hyphenated file and it can find a nonhyphenated sister, it loads that.  If that doesn't provide the getfn, it tries the original file.
This commit is contained in:
rmkaplan
2023-12-09 22:41:43 -08:00
committed by GitHub
parent c8c4768315
commit 72456ce4ec
2 changed files with 78 additions and 54 deletions
Download Patch File Download Diff File Expand all files Collapse all files

132
sources/WINDOWOBJ
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "29-Nov-2023 14:51:52" {WMEDLEY}<sources>WINDOWOBJ.;17 30975
(FILECREATED " 5-Dec-2023 21:15:38" {WMEDLEY}<sources>WINDOWOBJ.;23 32078
:EDIT-BY rmk
:CHANGES-TO (FNS READIMAGEOBJ)
:PREVIOUS-DATE "29-Nov-2023 14:14:32" {WMEDLEY}<sources>WINDOWOBJ.;15)
:PREVIOUS-DATE " 5-Dec-2023 20:44:27" {WMEDLEY}<sources>WINDOWOBJ.;22)
(PRETTYCOMPRINT WINDOWOBJCOMS)
@@ -312,11 +312,11 @@
(READIMAGEOBJ
[LAMBDA (STREAM GETFN NOERROR DATANBYTES)
(* ;; "Edited 5-Dec-2023 21:07 by rmk")
(* ;; "Edited 29-Nov-2023 14:51 by rmk")
(* ;; "Edited 18-Mar-2022 21:45 by rmk: Added WHEREIS as a last resort.")
(* rrb "18-Mar-86 11:35")
(DECLARE (SPECVARS UNDERREADIMAGEOBJ))
(* ;; "Reads an IMAGEOBJ, using GETFN. Verifies that the GETFN is legitimate")
@@ -324,55 +324,73 @@
(* ;; "rmk: I'm not sure that it makes sense for GETFN to be NIL, as 86 code allowed. Presumably an image object without a GETFN should never have been written.")
(LET (SUPPORTFILE HYPHENPOS SFNAME (UNDERREADIMAGEOBJ T))
(LET (OBJ GETFNFILE GETFNFILENAME HYPHENPOS MAINFILE FAILEDMSG (UNDERREADIMAGEOBJ T))
(DECLARE (SPECVARS UNDERREADIMAGEOBJ))
(* ;; "Typically,the file containing the GETFN has already been loaded. If not, it could be the case that the GETFN and its file were pushed on the list for future reference (now), but the file wasn't loaded then. We need to download it. Or if not there or not there with a file, and we can find the file containing the GETFN in the WHEREIS database, load that file.")
(* ;; "Typically,the file containing the GETFN has already been loaded. If not, it could be the case that the GETFN and its file were pushed on the list for future reference (now), but the file wasn't loaded then. We need to download it. We use the WHEREIS database to identify the file containing the GETFN. If it has a hyphenated name FOO-FIE and it has a sister file that named with just the prefix of the hyphen FOO, then we assume that the GETFN is in an internal file of a larger application FOO application, and we load FOO instead. Presumably that provides the GETFN.")
(* ;; "If we find the file with the GETFN but that file doesn't also contain the IMAGEFNS variable, we're screwed. That's why we apply the GETFN under an NLSETQ. As Plan B, if the getfn is on a file ...>abc>abc-xyz, and >abc>abc exists, then we offer to load the putative rootfile instead. (It would be nice to have UNPACKDIR and PACKDIR functions that map back and forth between a>b>c and (a b c).")
(* ;; "Note: the Prompt message only shows the NAME of the file, not the full path.")
(* ;; "Note: the Prompt message only shows the NAME of the file, not the full path")
(* ;; "Clean this up if we decide to nuke the MOUSECONFIRM")
(CL:WHEN (AND GETFN (NOT (GETD GETFN))
[SETQ SUPPORTFILE (OR (LISTGET (CDR (ASSOC GETFN IMAGEOBJGETFNS))
'FILE)
(CAR (WHEREIS GETFN 'FNS T))
(CAR (WHEREIS GETFN 'FUNCTIONS T]
(SETQ SUPPORTFILE (FINDFILE SUPPORTFILE T))
[SETQ GETFNFILENAME (OR (LISTGET (CDR (ASSOC GETFN IMAGEOBJGETFNS))
'FILE)
(CAR (WHEREIS GETFN 'FNS T))
(CAR (WHEREIS GETFN 'FUNCTIONS T]
[SETQ GETFNFILE (FINDFILE-WITH-EXTENSIONS GETFNFILENAME NIL
(APPEND *COMPILED-EXTENSIONS* (CONS NIL]
(PROG1 T
(CL:WHEN [SETQ HYPHENPOS (STRPOS "-" (SETQ SFNAME (FILENAMEFIELD.STRING
SUPPORTFILE
'NAME]
(SETQ SFNAME (SUBSTRING SFNAME 1 (SUB1 HYPHENPOS)))
(CL:WHEN (AND [STRING.EQUAL SFNAME (SUBSTRING (FILENAMEFIELD.STRING
(TRUEFILENAME
SUPPORTFILE)
'DIRECTORY)
(IMINUS (NCHARS SFNAME]
(INFILEP (PACKFILENAME 'NAME SFNAME 'BODY SUPPORTFILE)))
(SETQ SUPPORTFILE SFNAME))))
(MOUSECONFIRM (CONCAT "Trying to read an IMAGEOBJ with GETFN " GETFN
". Shall I load the support file, " SUPPORTFILE "?")
NIL NIL NIL))
(DOFILESLOAD (LIST '(SYSLOAD)
SUPPORTFILE)))
(COND
[(AND GETFN (GETD GETFN)
(CAR (NLSETQ (APPLY* GETFN STREAM]
(NOERROR NIL)
(T (* ;
(* ;; "Is FOO a sister of FOO-FIE ?")
(CL:WHEN (SETQ HYPHENPOS (STRPOS "-" GETFNFILENAME))
[SETQ MAINFILE (FINDFILE-WITH-EXTENSIONS (PACKFILENAME
'NAME
(SUBSTRING GETFNFILENAME 1
(SUB1 HYPHENPOS))
'VERSION NIL 'EXTENSION NIL
'BODY GETFNFILE)
NIL
(APPEND *COMPILED-EXTENSIONS* (CONS NIL]))
(if T
then
(* ;; "This makes for an automatic attempt. If we fail, well...")
(PROMPTPRINT "Getting GETFN " GETFN " by loading " (OR MAINFILE
GETFNFILE))
T
else (MOUSECONFIRM (CONCAT "Trying to read an IMAGEOBJ with GETFN " GETFN
". Shall I load the support file, " MAINFILE "?")
NIL NIL NIL)))
(* ;; "Hopefully we found the latest compiled versions")
(CL:WHEN MAINFILE
(DOFILESLOAD (LIST '(SYSLOAD)
MAINFILE)))
(CL:UNLESS (GETD GETFN) (* ;
 "Didn't find the GETFN: try the original GETFNFILE.")
(DOFILESLOAD (LIST '(SYSLOAD)
GETFNFILE))))
(if (NULL (GETD GETFN))
then (SETQ FAILEDMSG "Unknown")
elseif [SETQ OBJ (CAR (NLSETQ (APPLY* GETFN STREAM]
else (SETQ FAILEDMSG "Error in"))
(CL:UNLESS (OR OBJ NOERROR) (* ;
 "Still no support for this kind of IMAGEOBJ. Encapsulate it in something safe.")
(LET [(OBJ (IMAGEOBJCREATE NIL (ENCAPSULATEDIMAGEFNS GETFN]
(IMAGEOBJPROP OBJ 'FILE (FULLNAME STREAM)
STREAM) (* ;
(SETQ OBJ (IMAGEOBJCREATE NIL (ENCAPSULATEDIMAGEFNS GETFN)))
(IMAGEOBJPROP OBJ 'FILE (FULLNAME STREAM)
STREAM) (* ;
 "Remember which file it came from so that it could be written back out.")
(IMAGEOBJPROP OBJ 'FILEPTR (GETFILEPTR STREAM))
(* ; "And where on the file")
(IMAGEOBJPROP OBJ 'OBJSIZE DATANBYTES)
(IMAGEOBJPROP OBJ 'UNKNOWNGETFN GETFN) (* ; "And the name of its GETFN")
(AND DATANBYTES (SETFILEPTR STREAM (PLUS (GETFILEPTR STREAM)
DATANBYTES)))
OBJ])
(IMAGEOBJPROP OBJ 'FILEPTR (GETFILEPTR STREAM)) (* ; "And where on the file")
(IMAGEOBJPROP OBJ 'OBJSIZE DATANBYTES)
(IMAGEOBJPROP OBJ 'UNKNOWNGETFN GETFN) (* ; "And the name of its GETFN")
(IMAGEOBJPROP OBJ 'FAILEDMSG FAILEDMSG) (* ; "And why it failed")
(CL:WHEN DATANBYTES
(SETFILEPTR STREAM (PLUS (GETFILEPTR STREAM)
DATANBYTES))))
OBJ])
(WRITEIMAGEOBJ
[LAMBDA (IMAGEOBJ STREAM) (* jds "19-Feb-85 09:36")
@@ -460,12 +478,13 @@ Either delete this image object or load its support files." IMAGEOBJ)
T])
(ENCAPSULATEDOBJ.DISPLAYFN
[LAMBDA (OBJ STREAM) (* jds "19-Feb-85 10:37")
[LAMBDA (OBJ STREAM) (* ; "Edited 5-Dec-2023 12:12 by rmk")
(* jds "19-Feb-85 10:37")
(* ;; "Display function for an IMAGEOBJ that has been encapsulated for safety")
(* ;;
 "Displays as a box containing text saying 'Unknown IMAGEOBJ type' , and naming the unknown GETFN.")
 "Displays as a box containing text saying 'Unknown IMAGEOBJ type' , and naming the unknown GETFN.")
(LET* ((CURX (DSPXPOSITION NIL STREAM))
(CURY (DSPYPOSITION NIL STREAM))
@@ -481,7 +500,9 @@ Either delete this image object or load its support files." IMAGEOBJ)
(RELMOVETO 3 (IPLUS (FONTPROP FONT 'HEIGHT)
3)
STREAM)
(PRIN1 "Unknown IMAGEOBJ type" STREAM)
(PRIN1 (OR (IMAGEOBJPROP OBJ 'FAILEDMSG "Unknown"))
STREAM)
(PRIN1 " IMAGEOBJ" STREAM)
(MOVETO (IPLUS CURX 3)
(IPLUS CURY 3)
STREAM)
@@ -498,7 +519,8 @@ Either delete this image object or load its support files." IMAGEOBJ)
(DSPFONT OLDFONT STREAM])
(ENCAPSULATEDOBJ.IMAGEBOXFN
[LAMBDA (IMAGEOBJ STREAM) (* ; "Edited 29-Nov-2023 12:49 by rmk")
[LAMBDA (IMAGEOBJ STREAM) (* ; "Edited 5-Dec-2023 11:25 by rmk")
(* ; "Edited 29-Nov-2023 12:49 by rmk")
(* jds "19-Feb-85 10:05")
(* ;; "IMAGEOBXFN for an encapsulated IMAGEOBJ. If the GETFN now exists, another attempt is made to retrieve the underlying object and to use its boxfn. ")
@@ -516,7 +538,9 @@ Either delete this image object or load its support files." IMAGEOBJ)
IMAGEOBJ STREAM)
else (SETQ FONT (FONTCREATE 'HELVETICA 8 'BOLD NIL STREAM))
[SETQ HEIGHT (ITIMES 2 (FONTPROP FONT 'HEIGHT]
(SETQ WIDTH (IMAX (STRINGWIDTH "Unknown IMAGEOBJ type" FONT)
(SETQ WIDTH (IMAX (STRINGWIDTH (CONCAT (OR (IMAGEOBJPROP IMAGEOBJ 'FAILEDMSG)
"Unknown" " IMAGEOBJ"))
FONT)
(STRINGWIDTH (CONCAT "GETFN: " GETFN)
FONT)))
(create IMAGEBOX
@@ -564,11 +588,11 @@ Either delete this image object or load its support files." IMAGEOBJ)
(ADDTOVAR LAMA IMAGEOBJPROP)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (4766 22601 (COPYINSERT 4776 . 6303) (IMAGEBOX 6305 . 6485) (IMAGEFNSCREATE 6487 . 7682)
(FILEMAP (NIL (4766 23254 (COPYINSERT 4776 . 6303) (IMAGEBOX 6305 . 6485) (IMAGEFNSCREATE 6487 . 7682)
(IMAGEFNSP 7684 . 7925) (IMAGEOBJCREATE 7927 . 8472) (IMAGEOBJP 8474 . 8715) (IMAGEOBJPROP 8717 .
14609) (\IMAGEUSERPROP 14611 . 15205) (HPRINT.IMAGEOBJ 15207 . 15796) (COPYIMAGEOBJ 15798 . 16541) (
READIMAGEOBJ 16543 . 21247) (WRITEIMAGEOBJ 21249 . 22599)) (22815 30697 (
ENCAPSULATEDOBJ.BUTTONEVENTINFN 22825 . 24608) (ENCAPSULATEDOBJ.PUTFN 24610 . 25725) (
ENCAPSULATEDOBJ.DISPLAYFN 25727 . 27340) (ENCAPSULATEDOBJ.IMAGEBOXFN 27342 . 29258) (
ENCAPSULATEDIMAGEFNS 29260 . 30695)))))
READIMAGEOBJ 16543 . 21900) (WRITEIMAGEOBJ 21902 . 23252)) (23468 31800 (
ENCAPSULATEDOBJ.BUTTONEVENTINFN 23478 . 25261) (ENCAPSULATEDOBJ.PUTFN 25263 . 26378) (
ENCAPSULATEDOBJ.DISPLAYFN 26380 . 28183) (ENCAPSULATEDOBJ.IMAGEBOXFN 28185 . 30361) (
ENCAPSULATEDIMAGEFNS 30363 . 31798)))))
STOP

BIN
sources/WINDOWOBJ.LCOM
View File

Binary file not shown.