(FILECREATED "28-Mar-85 18:56:47" {ERIS}<LISPCORE>SOURCES>PUPPRINT.;2 15086
changes to: (FNS EFTP)
previous date: "30-Jan-85 22:25:27" {ERIS}<LISPCORE>SOURCES>PUPPRINT.;1)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT PUPPRINTCOMS)
(RPAQQ PUPPRINTCOMS ((FNS EFTP \ABORT.EFTP PUP.PRINTER.STATUS PUP.PRINTER.PROPERTIES)
(DECLARE: DONTCOPY (CONSTANTS * EFTPPUPTYPES)
(CONSTANTS * EFTPCONSTANTS)
(ADDVARS * (LIST (CONS (QUOTE PUPTYPES)
EFTPPUPTYPES)))
(GLOBALVARS \EFTP.TIMEOUT \EFTP.LONGTIMEOUT))
(INITVARS (\EFTP.TIMEOUT 5000)
(\EFTP.LONGTIMEOUT 15000))))
(DEFINEQ
(EFTP
[LAMBDA (HOST FILE PRINTOPTIONS) (* bvm: "28-Mar-85 18:46")
(RESETLST (PROG ((HOSTPORT (BESTPUPADDRESS HOST (QUOTE ERROR)))
(TIMEOUT \EFTP.TIMEOUT)
(CHECKSTATUS PRINTOPTIONS)
(OPUP (ALLOCATE.PUP))
#SIDES #COPIES DOCNAME CRDATE STREAM DATA RESULT ENDING USERNAMESTRING NC
HOSTNAME STATUS NEWSTATUS CURPAGE# ID SOC LASTPAGE# LASTPAGELENGTH LENGTH
THISPAGELENGTH PRESSDATAPAGE# ABORTER CLOSER CAPABILITIES IPUP)
[SETQ STREAM (COND
((TYPENAMEP FILE (QUOTE STREAM))
FILE)
(T (OPENSTREAM FILE (QUOTE INPUT]
(RESETSAVE NIL (SETQ CLOSER (LIST (QUOTE CLOSEF)
STREAM)))
(SETQ LENGTH (GETFILEINFO STREAM (QUOTE LENGTH)))
(SETQ LASTPAGELENGTH (fetch (BYTEPTR OFFSET) of LENGTH))
(SETQ LASTPAGE# (fetch (BYTEPTR PAGE) of LENGTH))
[COND
(PRINTOPTIONS (COND
((NEQ LASTPAGELENGTH 0)
(HELP "Press file with non-integral number of pages?" FILE)))
(* Final page of press file holds special printing
parameters)
(SETQ PRESSDATAPAGE# (SUB1 LASTPAGE#))
[COND
((NLISTP PRINTOPTIONS)
(* Old style, where this arg was #COPIES)
(SETQ #COPIES PRINTOPTIONS))
(T (* New style, prop list)
(SETQ #SIDES (LISTGET PRINTOPTIONS (QUOTE #SIDES)))
[COND
((SETQ DOCNAME (LISTGET PRINTOPTIONS (QUOTE DOCUMENT.NAME))
)
(SETQ DOCNAME (COND
((GREATERP (NCHARS DOCNAME)
51)
(* Format only allows 26-word bcpl string)
(SUBSTRING DOCNAME 1 51))
(T (MKSTRING DOCNAME]
(SETQ #COPIES (LISTGET PRINTOPTIONS (QUOTE #COPIES]
(COND
((NOT (AND (SMALLP #COPIES)
(IGREATERP #COPIES 0)))
(SETQ #COPIES 1)))
[COND
((SETQ CRDATE (LISTGET PRINTOPTIONS (QUOTE
DOCUMENT.CREATION.DATE)))
(OR (STRINGP CRDATE)
(SETQ CRDATE (GDATE CRDATE (DATEFORMAT TIME.ZONE]
(* Finally, figure out what to put in the
"Printed For:" field)
(COND
((IGREATERP [SETQ NC (NCHARS (SETQ USERNAMESTRING
(USERNAME NIL NIL T]
31) (* This field limited to 16-word bcpl string)
(SETQ USERNAMESTRING (SUBSTRING USERNAMESTRING 1 31)))
((ILESSP [IPLUS NC (NCHARS (SETQ HOSTNAME (ETHERHOSTNAME NIL T]
28)
(SETQ USERNAMESTRING (CONCAT USERNAMESTRING " on " HOSTNAME]
[RESETSAVE NIL (LIST (QUOTE CLOSEPUPSOCKET)
(SETQ SOC (OPENPUPSOCKET]
(SETUPPUP OPUP HOSTPORT \PUPSOCKET.EFTP \EFTP.DATA -1 SOC T)
(RESETSAVE NIL (SETQ ABORTER (LIST (QUOTE \ABORT.EFTP)
SOC OPUP)))
RESTART
(COND
((AND CURPAGE# PUPTRACEFLG)
(PRIN1 " (restarting)" PUPTRACEFILE)))
(SETQ ID 0)
(COND
((NEQ CURPAGE# 0)
[COND
((EQ (GETFILEPTR STREAM)
0))
((RANDACCESSP STREAM)
(SETFILEPTR STREAM 0))
(T (RPLACA (CDR CLOSER)
(SETQ STREAM (OPENSTREAM (CLOSEF STREAM)
(QUOTE INPUT]
(SETQ CURPAGE# 0)))
(replace PUPTYPE of OPUP with \EFTP.DATA)
[COND
((FIXP #SIDES)
[while (NOT CAPABILITIES)
do [do (* Printer capability request only honored while
printer is idle)
[COND
((SETQ NEWSTATUS (PUP.PRINTER.STATUS HOSTPORT))
(COND
((NOT (EQUAL NEWSTATUS STATUS))
(printout PROMPTWINDOW .TAB0 0 (CDR (SETQ STATUS NEWSTATUS]
(COND
((EQ (CAR STATUS)
\PS.IDLE)
(RETURN))
(T (BLOCK \EFTP.TIMEOUT]
(SETQ CHECKSTATUS NIL)
(COND
((NOT (SETQ CAPABILITIES (PUP.PRINTER.PROPERTIES HOSTPORT)))
(printout PROMPTWINDOW .TAB0 0 "[No response from " HOST "]")
(SETQ STATUS]
(COND
([AND (EQ (CHCON1 (CADR (ASSOC (QUOTE PRINT-INSTANCE)
CAPABILITIES)))
(CHARCODE T))
(OR (EQ #SIDES 1)
(EQ (CHCON1 (CADR (ASSOC (QUOTE DUPLEX)
CAPABILITIES)))
(CHARCODE T] (* Prepare capabilities)
(SETQ DATA (fetch PUPCONTENTS of OPUP))
(\PUTBASE DATA 0 \SPRUCEPWD1)
(\PUTBASE DATA 1 \SPRUCEPWD2)
(replace PUPLENGTH of OPUP
with (IPLUS (\STOREPLIST [LIST (LIST (QUOTE DUPLEX)
(COND
((EQ #SIDES 1)
(QUOTE FALSE))
(T (QUOTE TRUE]
(\ADDBASE DATA 2))
\PUPOVLEN 4)) (* Length of pup = length of plist plus overhead plus
two code words)
(SETQ CURPAGE# -1)
(GO SENDPAGE))
(T (printout T HOST " does not support #sides specification" T]
NEWPAGE
(COND
[(EQ CURPAGE# LASTPAGE#)
(COND
((EQ LASTPAGELENGTH 0)
(SETQ ENDING T))
(T (replace PUPLENGTH of OPUP with (IPLUS \PUPOVLEN (SETQ THISPAGELENGTH
LASTPAGELENGTH]
[(ILESSP CURPAGE# LASTPAGE#)
(replace PUPLENGTH of OPUP with (IPLUS \PUPOVLEN (SETQ THISPAGELENGTH
BYTESPERPAGE]
(T (SETQ ENDING T)))
[COND
(ENDING (replace PUPTYPE of OPUP with \EFTP.END)
(replace PUPLENGTH of OPUP with \PUPOVLEN))
((NEQ (fetch PUPID of OPUP)
ID) (* Read CURPAGE#'th page of file into pup's data part)
(\BINS STREAM (SETQ DATA (fetch PUPCONTENTS of OPUP))
0 THISPAGELENGTH)
(COND
((EQ CURPAGE# PRESSDATAPAGE#) (* Fill in print parameters for this run)
(\PUTBASE DATA 8 1) (* First copy to print = 1)
(\PUTBASE DATA 9 #COPIES) (* Number of copies)
(COND
(DOCNAME (SetBcplString (\ADDBASE DATA 128)
DOCNAME)))
(SetBcplString (\ADDBASE DATA 154)
USERNAMESTRING)))
(* Set "printed by")
(COND
(CRDATE (SetBcplString (\ADDBASE DATA 170)
CRDATE]
SENDPAGE
(replace PUPID of OPUP with ID)
[to \MAXETHERTRIES
do (COND
(CHECKSTATUS (COND
((AND (SETQ NEWSTATUS (PUP.PRINTER.STATUS HOSTPORT))
(NOT (EQUAL NEWSTATUS STATUS)))
(printout PROMPTWINDOW .TAB0 0 (CDR (SETQ STATUS
NEWSTATUS)))
(SELECTC (CAR STATUS)
((LIST \PS.BUSY \PS.NOTSPOOLING)
(* It may be a while. Maybe I should abort in case of
NOT SPOOLING, but by convention we just wait)
(SETQ TIMEOUT \EFTP.LONGTIMEOUT))
NIL)))
(SETQ CHECKSTATUS NIL)))
[COND
((SETQ IPUP (EXCHANGEPUPS SOC OPUP NIL NIL TIMEOUT))
(SELECTC (fetch PUPTYPE of IPUP)
[\EFTP.ACK (COND
((EQ (PROG1 (fetch PUPID of IPUP)
(RELEASE.PUP IPUP))
ID)
(* Packet acknowledged, proceed normally)
(add ID 1)
(add CURPAGE# 1)
(COND
(ENDING
(* Acknowledged the END signal.
We now echo the END one bigger, so that the receiver
can stop dallying)
(replace PUPID of OPUP with ID)
(SENDPUP SOC OPUP)
(GO DONE))
(T (GO NEWPAGE]
(\EFTP.ABORT (COND
(PUPTRACEFLG (PRIN1 "[abort]" PUPTRACEFILE)))
(SELECTC (PROG1 (\GETPUPWORD IPUP 0)
(* EFTP abort code)
(RELEASE.PUP IPUP))
(\EABORT.RECEIVER
(* it didn't like the file for some reason)
(SETQ RESULT
(CONS (QUOTE REJECT)
(GETPUPSTRING
IPUP 2)))
(GO ABORT))
(\EABORT.BUSY (DISMISS \EFTP.LONGTIMEOUT)
)
(\EABORT.SYNCH
(* Out of synch--start over))
NIL)
(GO RESTART))
(RELEASE.PUP IPUP]
(COND
((AND PRINTOPTIONS (EQ ID 0)) (* What's going on? Check status again)
(SETQ CHECKSTATUS T)))
finally (COND
(ENDING (* Well , we never got the end acknowledged, but it
probably worked)
(GO DONE))
(T (printout PROMPTWINDOW .TAB0 0 "[No response from " HOST "]")
(GO RESTART]
DONE (* succeeded, flush abort code)
(FRPLACA ABORTER (QUOTE *))
(SETQ RESULT (fetch FULLNAME of STREAM))
ABORT
(RETURN RESULT])
(\ABORT.EFTP
[LAMBDA (SOC PUP) (* bvm: " 3-NOV-82 11:17")
(* * Aborts the EFTP transfer in progress to SOC, using PUP for an output pup)
(replace PUPTYPE of PUP with \EFTP.ABORT)
(replace PUPLENGTH of PUP with (ADD1 \PUPOVLEN))
(\PUTBASE (fetch PUPCONTENTS of PUP)
0 \EABORT.SENDER)
(SENDPUP SOC PUP])
(PUP.PRINTER.STATUS
[LAMBDA (PRINTER) (* bvm: "13-Dec-83 15:55")
(* * Checks status of printer, returns a dotted pair (statuscode . string))
(PROG ((HOSTPORT (BESTPUPADDRESS PRINTER PROMPTWINDOW))
(SOC (\GETMISCSOCKET))
(OPUP (ALLOCATE.PUP))
RESULT IPUP)
(OR HOSTPORT (RETURN))
(SETUPPUP OPUP HOSTPORT \PUPSOCKET.PRINTERSTATUS \PT.PRINTERSTATUS NIL SOC)
(to \MAXETHERTRIES when (SETQ IPUP (EXCHANGEPUPS SOC OPUP NIL T))
do (SELECTC (fetch PUPTYPE of IPUP)
[\PT.STATUSRESPONSE (RETURN (PROG1 (SETQ RESULT
(CONS (\GETBASE (fetch PUPCONTENTS
of IPUP)
0)
(GETPUPSTRING IPUP 2)))
(RELEASE.PUP IPUP]
(\PT.ERROR (AND PUPTRACEFLG (PRINTERRORPUP IPUP PUPTRACEFILE))
(RETURN (RELEASE.PUP IPUP)))
(RELEASE.PUP IPUP))
finally (PUPDEBUGGING "Printer status request timed out" T))
(RELEASE.PUP OPUP)
(RETURN RESULT])
(PUP.PRINTER.PROPERTIES
[LAMBDA (PRINTER) (* bvm: " 1-NOV-83 16:00")
(* * Asks printer about its capabilities, returns property list)
(PROG ((HOSTPORT (BESTPUPADDRESS PRINTER PROMPTWINDOW))
(SOC (\GETMISCSOCKET))
(OPUP (ALLOCATE.PUP))
RESULT IPUP)
(OR HOSTPORT (RETURN))
(SETUPPUP OPUP HOSTPORT \PUPSOCKET.PRINTERSTATUS \PT.PRINTERCAPABILITY NIL SOC)
(to \MAXETHERTRIES when (SETQ IPUP (EXCHANGEPUPS SOC OPUP NIL T))
do (SELECTC (fetch PUPTYPE of IPUP)
[\PT.CAPABILITYRESPONSE (RETURN (SETQ RESULT (READPLIST (GETPUPSTREAM IPUP]
(\PT.ERROR (AND PUPTRACEFLG (PRINTERRORPUP IPUP PUPTRACEFILE))
(RETURN))
NIL)
finally (PUPDEBUGGING "Printer capability request timed out" T))
(AND IPUP (RELEASE.PUP IPUP))
(RETURN RESULT])
)
(DECLARE: DONTCOPY
(RPAQQ EFTPPUPTYPES ((\EFTP.DATA 24)
(\EFTP.ACK 25)
(\EFTP.END 26)
(\EFTP.ABORT 27)))
(DECLARE: EVAL@COMPILE
(RPAQQ \EFTP.DATA 24)
(RPAQQ \EFTP.ACK 25)
(RPAQQ \EFTP.END 26)
(RPAQQ \EFTP.ABORT 27)
(CONSTANTS (\EFTP.DATA 24)
(\EFTP.ACK 25)
(\EFTP.END 26)
(\EFTP.ABORT 27))
)
(RPAQQ EFTPCONSTANTS ((\EABORT.SENDER 1)
(\EABORT.RECEIVER 2)
(\EABORT.BUSY 3)
(\EABORT.SYNCH 4)
(\EABORT.LONGWAIT 6)
(\EABORT.MEDWAIT 7)
(\EABORT.SUSPEND 8)
(\PS.NOTSPOOLING 1)
(\PS.IDLE 2)
(\PS.BUSY 3)
(\SPRUCEPWD1 43724)
(\SPRUCEPWD2 61695)))
(DECLARE: EVAL@COMPILE
(RPAQQ \EABORT.SENDER 1)
(RPAQQ \EABORT.RECEIVER 2)
(RPAQQ \EABORT.BUSY 3)
(RPAQQ \EABORT.SYNCH 4)
(RPAQQ \EABORT.LONGWAIT 6)
(RPAQQ \EABORT.MEDWAIT 7)
(RPAQQ \EABORT.SUSPEND 8)
(RPAQQ \PS.NOTSPOOLING 1)
(RPAQQ \PS.IDLE 2)
(RPAQQ \PS.BUSY 3)
(RPAQQ \SPRUCEPWD1 43724)
(RPAQQ \SPRUCEPWD2 61695)
(CONSTANTS (\EABORT.SENDER 1)
(\EABORT.RECEIVER 2)
(\EABORT.BUSY 3)
(\EABORT.SYNCH 4)
(\EABORT.LONGWAIT 6)
(\EABORT.MEDWAIT 7)
(\EABORT.SUSPEND 8)
(\PS.NOTSPOOLING 1)
(\PS.IDLE 2)
(\PS.BUSY 3)
(\SPRUCEPWD1 43724)
(\SPRUCEPWD2 61695))
)
(ADDTOVAR PUPTYPES (\EFTP.DATA 24)
(\EFTP.ACK 25)
(\EFTP.END 26)
(\EFTP.ABORT 27))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \EFTP.TIMEOUT \EFTP.LONGTIMEOUT)
)
)
(RPAQ? \EFTP.TIMEOUT 5000)
(RPAQ? \EFTP.LONGTIMEOUT 15000)
(PUTPROPS PUPPRINT COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (687 13397 (EFTP 697 . 10807) (\ABORT.EFTP 10809 . 11245) (PUP.PRINTER.STATUS 11247 .
12405) (PUP.PRINTER.PROPERTIES 12407 . 13395)))))
STOP