(FILECREATED "11-Jun-87 16:52:54" {QV}<NOTECARDS>1.3K>NEXT>KOTOSYSTEMPATCHES.;11 14154
changes to: (VARS KOTOSYSTEMPATCHESCOMS)
previous date: "24-Apr-87 11:49:53" {QV}<NOTECARDS>1.3K>NEXT>KOTOSYSTEMPATCHES.;10)
(* Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT KOTOSYSTEMPATCHESCOMS)
(RPAQQ KOTOSYSTEMPATCHESCOMS [(* * to compile SHAPEW must have EXPORTS.ALL loaded)
(DECLARE: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY (FILES EXPORTS.ALL))
(FNS SHAPEW \NSPRINT.INTERNAL COPY.TEXT.TO.IMAGE)
(* * fgh&rht 8/6/86: Insure that correct imageobj HPRINTMACRO is at
front of the HPRINTMACROS list.)
(FNS WRITE.IMAGEOBJ)
(ADDVARS (HPRINTMACROS (IMAGEOBJ . WRITE.IMAGEOBJ])
(* * to compile SHAPEW must have EXPORTS.ALL loaded)
(DECLARE: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY
(FILESLOAD EXPORTS.ALL)
)
(DEFINEQ
(SHAPEW
(LAMBDA (WINDOW NEWREGION) (* fgh: " 6-Jun-86 19:31")
(* entry that shapes a window checking the userfns for DON'T and interacting to get a region if necessary.
This also checks for a user function to do the actual reshaping. look for a function on windowprop INITCORNERSFN,
which will take the window and return the initcorners for the window, to be passed to getregion.)
(SETQ WINDOW (\INSUREWINDOW WINDOW))
(PROG (USERFN X)
(COND
((\USERFNISDON'T (fetch (WINDOW RESHAPEFN) of WINDOW))
(* don't allow the window to be reshaped.)
(PROMPTPRINT "This window cannot be reshaped.")
(RETURN NIL)))
(SETQ X (MINIMUMWINDOWSIZE WINDOW))
(SETQ X (COND
(NEWREGION (COND
((OR (LESSP (fetch (REGION WIDTH) of NEWREGION)
(CAR X))
(LESSP (fetch (REGION HEIGHT) of NEWREGION)
(CDR X))) (* given a region that is too small)
(CREATEREGION (fetch (REGION LEFT) of NEWREGION)
(fetch (REGION BOTTOM) of NEWREGION)
(MAX (CAR X)
(fetch (REGION WIDTH) of NEWREGION))
(MAX (CDR X)
(fetch (REGION HEIGHT) of NEWREGION))))
(T NEWREGION)))
((WINDOWPROP WINDOW (QUOTE INITCORNERSFN))
(GETREGION (CAR X)
(CDR X)
(WINDOWREGION WINDOW (QUOTE SHAPEW))
(fetch NEWREGIONFN of WINDOW)
WINDOW
(APPLY* (WINDOWPROP WINDOW (QUOTE INITCORNERSFN))
WINDOW)))
(T (GETREGION (CAR X)
(CDR X)
(WINDOWREGION WINDOW (QUOTE SHAPEW))
(fetch NEWREGIONFN of WINDOW)
WINDOW))))
(RETURN (COND
((SETQ USERFN (WINDOWPROP WINDOW (QUOTE DOSHAPEFN)))
(APPLY* USERFN WINDOW X))
(T (SHAPEW1 WINDOW X)))))))
(\NSPRINT.INTERNAL
[LAMBDA (PRINTER OPTIONS TRANSFERFN) (* Randy.Gobbel "11-Dec-86 12:37")
(* * Calls the PRINT program for PRINTER, interpreting OPTIONS as a plist of print options.
TRANSFERFN is a function applied to the transfer stream to actually send the Interpress master)
(PROG ((MEDIUM (OR (LISTGET OPTIONS (QUOTE MEDIUM))
NSPRINT.DEFAULT.MEDIUM))
(STAPLE? (LISTGET OPTIONS (QUOTE STAPLE?)))
(TWO.SIDED? (EQ 2 (OR (LISTGET OPTIONS (QUOTE #SIDES))
EMPRESS#SIDES)))
(SENDER.NAME (OR (LISTGET OPTIONS (QUOTE SENDER.NAME))
(USERNAME NIL NIL T)))
(DOCNAME (OR (LISTGET OPTIONS (QUOTE DOCUMENT.NAME))
"Document"))
PROPERTIES ATTRIBUTES COURIERSTREAM VALUE PRINTOPTIONS STATUS)
[SETQ ATTRIBUTES (BQUOTE ((PRINT.OBJECT.NAME , DOCNAME)
(PRINT.OBJECT.CREATE.DATE , (OR (LISTGET OPTIONS
(QUOTE
DOCUMENT.CREATION.DATE))
(IDATE)))
(SENDER.NAME , SENDER.NAME]
[SETQ PRINTOPTIONS (BQUOTE ((COPY.COUNT , (FIX (OR (LISTGET OPTIONS
(QUOTE #COPIES))
1]
(* This "option" seems to be required)
[COND
((SETQ VALUE (LISTGET OPTIONS (QUOTE RECIPIENT.NAME)))
(push PRINTOPTIONS (LIST (QUOTE RECIPIENT.NAME)
(OR (STRINGP VALUE)
(MKSTRING VALUE]
[COND
((SETQ VALUE (LISTGET OPTIONS (QUOTE PRIORITY)))
(push PRINTOPTIONS (LIST (QUOTE PRIORITY.HINT)
(SELECTQ VALUE
((HOLD LOW NORMAL HIGH)
VALUE)
(\ILLEGAL.ARG VALUE]
[COND
((SETQ VALUE (LISTGET OPTIONS (QUOTE MESSAGE)))
(push PRINTOPTIONS (LIST (QUOTE MESSAGE)
(OR (STRINGP VALUE)
(MKSTRING VALUE]
[COND
((SETQ VALUE (LISTGET OPTIONS (QUOTE PAGES.TO.PRINT)))
(* A page range to print, (first# last#))
(COND
((AND (LISTP VALUE)
(LISTP (CDR VALUE))
(NULL (CDDR VALUE))
(SMALLPOSP (CAR VALUE))
(SMALLPOSP (CADR VALUE)))
(push PRINTOPTIONS (LIST (QUOTE PAGES.TO.PRINT)
VALUE)))
(T (\ILLEGAL.ARG VALUE]
RETRY
(COND
((NOT (SETQ COURIERSTREAM (\NSPRINT.COURIER.OPEN PRINTER)))
(printout PROMPTWINDOW .TAB0 0 "No response from printer " (fetch NSPRINTERNAME
of PRINTER))
(DISMISS 5000)
(GO RETRY)))
(RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE)
COURIERSTREAM)) (* Check the status of the printer.)
(bind (LASTSTATUS ← 0)
do (SETQ STATUS (COURIER.CALL COURIERSTREAM (QUOTE PRINTING)
(QUOTE GET.PRINTER.STATUS)
(QUOTE RETURNERRORS)))
[COND
((EQ (CAR STATUS)
(QUOTE ERROR))
(COND
((NOT (EQUAL STATUS LASTSTATUS))
(printout PROMPTWINDOW T "[From " (fetch NSPRINTERNAME of PRINTER)
" Error: "
(SUBSTRING (CDR STATUS)
2 -2)
"; will retry]"))) (* Wait longer for this problem)
(DISMISS 30000))
((NEQ (SETQ STATUS (CADR (ASSOC (QUOTE SPOOLER)
STATUS)))
LASTSTATUS)
(SELECTQ STATUS
(Available (RETURN))
(Busy (printout PROMPTWINDOW T "[From " (fetch NSPRINTERNAME
of PRINTER)
" Status: Spooler busy; will retry]"))
(ERROR "Printer spooler" STATUS]
(SETQ LASTSTATUS STATUS)
(DISMISS 5000))
[COND
((OR MEDIUM STAPLE? TWO.SIDED?) (* Check that the printer supports these options.)
(SETQ PROPERTIES (COURIER.CALL COURIERSTREAM (QUOTE PRINTING)
(QUOTE GET.PRINTER.PROPERTIES)
(QUOTE RETURNERRORS)))
(COND
((EQ (CAR PROPERTIES)
(QUOTE ERROR))
(SETQ STATUS PROPERTIES)
(GO HANDLE.ERROR)))
[COND
(MEDIUM (COND
((SETQ VALUE (\NSPRINT.MEDIUM.CHECK MEDIUM
(CADR (ASSOC (QUOTE MEDIA)
PROPERTIES))
PRINTER))
(push PRINTOPTIONS (LIST (QUOTE MEDIUM.HINT)
VALUE))
(SETQ MEDIUM]
[COND
(STAPLE? (COND
((CADR (ASSOC (QUOTE STAPLE)
PROPERTIES))
(push PRINTOPTIONS (LIST (QUOTE STAPLE)
T))
(SETQ STAPLE?))
(T (printout PROMPTWINDOW .TAB0 0
"[Printer does not support stapled copies]"]
(COND
(TWO.SIDED? (COND
((CADR (ASSOC (QUOTE TWO.SIDED)
PROPERTIES))
(push PRINTOPTIONS (QUOTE (TWO.SIDED T)))
(SETQ TWO.SIDED?))
(T (printout PROMPTWINDOW .TAB0 0
"Printer does not support two-sided copies"]
(* * Finally, send the print document)
(SETQ STATUS (COURIER.CALL COURIERSTREAM (QUOTE PRINTING)
(QUOTE PRINT)
TRANSFERFN ATTRIBUTES PRINTOPTIONS (QUOTE RETURNERRORS)))
(COND
((NEQ (CAR STATUS)
(QUOTE ERROR))
(RETURN STATUS)))
HANDLE.ERROR
(ERROR (CONCAT "Unexpected error from " (fetch NSPRINTERNAME of PRINTER)
" attempting to print " DOCNAME "
RETURN to try again.")
(CDR STATUS))
(CLOSEF COURIERSTREAM)
(GO RETRY])
(COPY.TEXT.TO.IMAGE
[LAMBDA (INFILE IMAGESTREAM FONTS TABS) (* Randy.Gobbel "28-Jan-87 18:22")
(* Copy text to an image stream, obeying PSPOOL
control characters)
(LET* ((IMAGESTREAM (GETSTREAM IMAGESTREAM (QUOTE OUTPUT)))
C FC (FONTARRAY (FONTMAPARRAY FONTS))
(MAXFONT (ARRAYSIZE FONTARRAY))
(INSTRM (GETSTREAM INFILE (QUOTE INPUT)))
(INEOLC (GETFILEINFO INSTRM (QUOTE EOL)))
(RIGHTMAR (DSPRIGHTMARGIN NIL IMAGESTREAM)))
(replace (STREAM ENDOFSTREAMOP) of INSTRM with (FUNCTION ZERO))
(bind (SHIFTEDCHARSET ← (UNFOLD (ffetch CHARSET of INSTRM)
256))
do (BLOCK)
(COND
((AND (EQ 0 (SETQ C (\NSIN INSTRM SHIFTEDCHARSET SHIFTEDCHARSET)))
(EOFP INSTRM))
(RETURN))
((AND RIGHTMAR (IGREATERP (DSPXPOSITION NIL IMAGESTREAM)
RIGHTMAR))
(* Not to walk off the right edge of the paper)
(TERPRI IMAGESTREAM)))
(COND
([IGREATERP C (CONSTANT (APPLY (FUNCTION MAX)
(CHARCODE (↑F CR LF ↑L TAB NULL]
(\OUTCHAR IMAGESTREAM C))
(T (SELCHARQ C
[↑F (* Font shift)
(SELCHARQ (SETQ FC (\NSIN INSTRM SHIFTEDCHARSET SHIFTEDCHARSET)
)
[↑T (* tab to absolute pos.)
(COND
((EQ 0 (SETQ FC (\NSIN INSTRM SHIFTEDCHARSET
SHIFTEDCHARSET)))
(\OUTCHAR IMAGESTREAM (CHARCODE ↑F))
(\OUTCHAR IMAGESTREAM (CHARCODE ↑T))
(AND (\EOFP INSTRM)
(RETURN))
(\OUTCHAR IMAGESTREAM FC))
(T
(* TEXTDEFAULTTABS is a hack, since it depends on the units of the stream. Should really be a property of the
stream or imagetype, or defined in terms of standard scale)
(SETQ FC
(OR (CAR (NTH (OR TABS
TEXTDEFAULTTABS)
FC))
(ERROR
"Undefined absolute tab number"
FC)))
(DSPXPOSITION FC IMAGESTREAM]
(NULL (\OUTCHAR IMAGESTREAM (CHARCODE ↑F))
(AND (\EOFP INSTRM)
(RETURN))
(\OUTCHAR IMAGESTREAM FC)
(* EOS after ↑F)
)
(COND
((AND (IGEQ MAXFONT FC)
(NEQ FC 0))
(DSPFONT (ELT FONTARRAY FC)
IMAGESTREAM))
(T (\OUTCHAR IMAGESTREAM (CHARCODE ↑F))
(\OUTCHAR IMAGESTREAM C]
(CR (* Don't call generic \CHECKEOLC macro, because we are
trying to disciminate the raw CR and raw LF cases for
printing)
(* Note: Assumes, as does \CHECKEOLC and \FILEOUTCHARFN that the LF character will be generated immediately after
the CR, independent of the encoding, perhaps by a file-transfer protocol)
(SELECTQ INEOLC
(CR (TERPRI IMAGESTREAM))
[CRLF (COND
((EQ (CHARCODE LF)
(\PEEKBIN INSTRM T))
(BIN INSTRM)
(TERPRI IMAGESTREAM))
(T (DSPXPOSITION (DSPLEFTMARGIN NIL
IMAGESTREAM)
IMAGESTREAM)
(* Move to left margin)
]
(DSPXPOSITION (DSPLEFTMARGIN NIL IMAGESTREAM)
IMAGESTREAM)))
(TAB (OR (NLSETQ (RELMOVETO (TIMES (CHARWIDTH
(CHARCODE SPACE)
IMAGESTREAM)
8)
0 IMAGESTREAM))
(\OUTCHAR IMAGESTREAM C)))
[LF (COND
((EQ INEOLC (QUOTE LF))
(TERPRI IMAGESTREAM))
(T (DSPXPOSITION (PROG1 (DSPXPOSITION NIL IMAGESTREAM)
(TERPRI IMAGESTREAM))
IMAGESTREAM]
(NULL (AND (EOFP INSTRM)
(RETURN))
(\OUTCHAR IMAGESTREAM C))
(\OUTCHAR IMAGESTREAM C])
)
(* * fgh&rht 8/6/86: Insure that correct imageobj HPRINTMACRO is at front of the HPRINTMACROS
list.)
(DEFINEQ
(WRITE.IMAGEOBJ
(LAMBDA (IMAGEOBJ STREAM) (* rrb "19-Dec-84 14:50")
(* HPRINT function for writing out IMAGE OBJECTS)
(* write out the name of the function to read things
back in with.)
(PRINT (LIST (fetch (IMAGEFNS GETFN) of (fetch (IMAGEOBJ IMAGEOBJFNS) of IMAGEOBJ)))
STREAM HPRINTRDTBL)
(APPLY* (fetch (IMAGEFNS PUTFN) of (fetch (IMAGEOBJ IMAGEOBJFNS) of IMAGEOBJ))
IMAGEOBJ STREAM)
T))
)
(ADDTOVAR HPRINTMACROS (IMAGEOBJ . WRITE.IMAGEOBJ))
(PUTPROPS KOTOSYSTEMPATCHES COPYRIGHT ("Xerox Corporation" 1986 1987))
(DECLARE: DONTCOPY
(FILEMAP (NIL (888 13234 (SHAPEW 898 . 2993) (\NSPRINT.INTERNAL 2995 . 8853) (COPY.TEXT.TO.IMAGE 8855
. 13232)) (13343 14004 (WRITE.IMAGEOBJ 13353 . 14002)))))
STOP