(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")

(filecreated "29-Dec-87 14:01:40" |{EG:PARC:XEROX}<JELLINEK>LISPUSERS>HARDCOPY-RETAIN.;2|
 6163   

      |changes| |to:|  (functions hardcopyimagew.tofile&printer xcl-user::install-option)
                       (vars hardcopy-retaincoms)

      |previous| |date:| "29-Dec-87 12:27:25" |{EG:PARC:XEROX}<JELLINEK>LISPUSERS>HARDCOPY-RETAIN.;1|
)


; Copyright (c) 1987 by Xerox Corporation.  All rights reserved.

(prettycomprint hardcopy-retaincoms)

(rpaqq hardcopy-retaincoms
 ((functions hardcopyimagew.tofile&printer xcl-user::install-option)
                            (p (xcl-user::install-option))))

(cl:defun hardcopyimagew.tofile&printer
 (&optional xcl-user::window) 
                                                   "Send hardcopy of WINDOW to a printer and a file."
   (let
    ((xcl-user::result (|GetImageFile|)))
    (cl:when
     xcl-user::result
     (let ((xcl-user::printer-name (|GetPrinterName|)))
          (destructuring-bind
           (xcl-user::file . type)
           xcl-user::result
           (hardcopy.somehow xcl-user::window xcl-user::file type)
           (cl:when xcl-user::printer-name
                  (let ((xcl-user::full-name (packfilename.string
                                              'host
                                              (cl:pathname-host xcl-user::file)
                                              'device
                                              (cl:pathname-device xcl-user::file)
                                              'directory
                                              (cl:pathname-directory xcl-user::file)
                                              'name
                                              (cl:pathname-name xcl-user::file)
                                              'extension
                                              (or (cl:first (cl:second (cl:assoc 'extension
                                                                              (cl:rest (cl:assoc
                                                                                        type 
                                                                                       printfiletypes
                                                                                        )))))
                                                  type)
                                              'body
                                              (cl:namestring *default-pathname-defaults*))))
                       (send.file.to.printer xcl-user::full-name xcl-user::printer-name))))))))


(cl:defun install-option
 nil "Install the new Hardcopy option."
   (cl:labels ((xcl-user::get-subitems (xcl-user::item)
                      (and (eq (cl:first (cl:fourth xcl-user::item))
                               'subitems)
                           (cl:rest (cl:fourth xcl-user::item))))
               (xcl-user::find-place-wm
                (xcl-user::item)
                (let ((xcl-user::subitems (xcl-user::get-subitems xcl-user::item)))
                     (cl:when xcl-user::subitems
                            (cl:if (eq (car xcl-user::item)
                                       '|Hardcopy|)
                                   (cl:unless                (* \; "Install if not already there.")


                                          (cl:find 'hardcopyimagew.tofile&printer xcl-user::subitems 
                                                 :key #'(cl:lambda (xcl-user::x)
                                                               (cl:second (cl:second xcl-user::x))) 
                                                 :test #'eq)
                                          (nconc xcl-user::subitems (list (list 
                                                                            "To a file and a printer"
                                                                                ''
                                                                        hardcopyimagew.tofile&printer 
              "Sends image to a printer of your choosing, retaining the printer version of the file."
                                                                                ))))
                                   (cl:mapc #'xcl-user::find-place-wm xcl-user::subitems)))))
               (xcl-user::find-place-bm
                (xcl-user::item)
                (let ((xcl-user::subitems (xcl-user::get-subitems xcl-user::item)))
                     (cl:when xcl-user::subitems
                            (cl:if (eq (car xcl-user::item)
                                       '|Hardcopy|)
                                   (cl:unless                (* \; "Install if not already there.")


                                          (cl:find 'hardcopyimagew.tofile&printer xcl-user::subitems 
                                                 :key #'(cl:lambda (xcl-user::x)
                                                               (cl:first (cl:second (cl:second 
                                                                                          xcl-user::x
                                                                                           )))) :test
                                                 #'eq)
                                          (nconc xcl-user::subitems
                                                 (list (list "To a file and a printer"
                                                             ''(hardcopyimagew.tofile&printer) 
              "Sends image to a printer of your choosing, retaining the printer version of the file."
                                                             ))))
                                   (cl:mapc #'xcl-user::find-place-bm xcl-user::subitems))))))
          (cl:mapc #'xcl-user::find-place-wm |WindowMenuCommands|)
          (cl:mapc #'xcl-user::find-place-bm |BackgroundMenuCommands|)
          (cl:setq |WindowMenu| nil)
          (cl:setq |BackgroundMenu| nil)))

(xcl-user::install-option)
(putprops hardcopy-retain copyright ("Xerox Corporation" 1987))
(declare\: dontcopy
  (filemap (nil)))
stop