[Indigo]<AltoSource>EMPRESSSOURCES.DM!2>Empress.bcpl

get "Streams.d"

external
[
//outgoing procedures
SendToPrinter; FinishUp; GetPrinterStatus; GetDateAndTime

//incoming procedures from Empress1
InitCompose; ComposePressFile

//incoming procedures from EmpressInit
SearchUserCm; FreeSpaceToSysZone; GetParameters; SetUpFileNames

//incoming procedures from EmpressParse
isPressFile; pagePosition; copyPressFile

//incoming procedures from PrinterPList
Nin; ScanPList; InitPListStream; WriteStringProp; WriteNumberProp; WriteBooleanProp

//incoming procedures from OS
OpenFile; ReadBlock; FilePos; FileLength
Endofs; Gets; Closes; Puts; Resets; Stateofs
Ws; Wss; CallSwat; MoveBlock; Zero; MyFrame
Allocate; Free; ReadCalendar
//InitializeFstream; SetupFstream

//incoming procedures from packages
PutTemplate
ExtractSubstring; CreateStringStream; StringCompare; ConcatenateStrings
Enqueue; Dequeue; SetTimer; TimerHasExpired
InitializeContext; CallContextList; Block; Dismiss
OpenLevel1Socket; CloseLevel1Socket
GetPBI; ReleasePBI; CompletePup; GetPartner
OpenEFTPSoc; CloseEFTPSoc
GetEFTPAbort; SendEFTPBlock; SendEFTPEnd

//outgoing statics
breakPageName; printedBy; headerDate
widthTab; leading; pointSize; fontName; numCopies
numInputNames; currentInputName; maxInputNames
inputNames; inputDVs; pressFile; merging; heading; forceDate
addresseeName; keyString; docName; titleString;
weight; slope; expansion;
printerName; localFilename; transmitFlag; waitFlag
ctxQ; printerPort; statusStream
usingSwatee; resetSwatee
password; forName; duplex; forceDuplex

//incoming statics from OS
keys; dsp; sysZone

//incoming statics from Empress1
headerName

//incoming statics from EmpressParse
addresseesFinished
]

compiletest alto
ifso
[
external
[
//incoming procedures
CONVUDT
TruncateDiskStream; PositionPage
LoadRam; InitBcplRuntime

//incoming statics
UserName
RamImage
]
]
ifnot
[
external
[
InitNovaAlto
]
]

static
[
breakPageName; printedBy; headerDate
widthTab; pointSize; fontName; numCopies
numInputNames = 0; currentInputName = 0; maxInputNames = 100
inputNames; inputDVs; itWentOK; longRetryCount
ctxQ; printerPort; printerName = 0; transmitFlag = true
statusStream; localFilename; usingSwatee; resetSwatee; heading; forceDate
pressFile; addresseeName; keyString; docName; titleString
merging = false; waitFlag = false
weight; slope; expansion;
printerDouble; printerColor //Boolean
printInstanceID; printerMaxFile; printerCurrentFile
printerUnderstandsPLists
password; forName; duplex; forceDuplex
]

manifest
[
stackLimit = #335
DEL = #177

socketPrinterStatus = #21
socketPrinterServer = #20

typePrinterStatusRequest = #200
typePrinterStatusReply = #201
typePrCapabilityRequest = #202
typePrCapabilityReply = #203
typeJobStatusRequest = #204
typeJobStatusReply = #205

//printer Statuses
psNotResponding = 0
psNotSpooling = 1
psSpoolingAndWaiting = 2
psSpoolingAndBusy = 3

PrInstPass0 = #125314
PrInstPass1 = #170377

longWaitAbort = 6 // Spruce has disabled spooling -- who knows when it’ll be back
]

//----------------------------------------------------
structure String: [ length byte; char↑1,1 byte ]
//----------------------------------------------------

//----------------------------------------------------
let Empress(layout) be
//----------------------------------------------------
[
compileif alto then
[
if LoadRam(RamImage) eq 0 then InitBcplRuntime()
@stackLimit = layout!($A-$A)// Recover space
]

FreeSpaceToSysZone()
ctxQ = Allocate(sysZone,2); ctxQ!0 = 0
Enqueue(ctxQ,InitializeContext(Allocate(sysZone,2000),2000,Main))
compileif nova then [ InitNovaAlto(sysZone) ]
CallContextList(ctxQ!0) repeat //forever
]

//----------------------------------------------------
and Main() be
//----------------------------------------------------
[
Ws("Empress of September 24, 1982")

GetParameters()
SetUpFileNames()

pressFile = OpenFile(localFilename,ksTypeReadWrite,charItem)
let fPos = vec 1; let lenSwatee = 256
test usingSwatee ifso // remember how long it is
[
unless resetSwatee do
[
FileLength(pressFile,fPos)
lenSwatee = pagePosition(fPos) + 1
Resets(pressFile)
]
]
ifnot
[
unless Endofs(pressFile) do //already exists
[
PutTemplate(dsp,"*NOutput file $S already exists. Overwrite? [Confirm] ",
localFilename)
let char = Gets(keys)
test (char eq $*n) % (char eq $y) % (char eq $Y)
ifnot [ Ws("No*n"); FinishUp() ]
ifso Ws("Yes*n")
]
]

InitCompose()
until currentInputName eq numInputNames do
[
if usingSwatee
then breakPageName = inputNames!currentInputName
ComposePressFile(pressFile,transmitFlag)
FilePos(pressFile,fPos)
let lastPage = pagePosition(fPos)
if transmitFlag & lastPage ne 0 then
SendToPrinter(pressFile, lastPage, true)
if merging & not addresseesFinished do
[
currentInputName = 0
loop
]
]

compileif alto then
[
if usingSwatee then //make sure we haven’t extended it
[
PositionPage(pressFile, lenSwatee)
TruncateDiskStream(pressFile)
]
]
Closes(pressFile)
unless usingSwatee do PutTemplate(dsp,"*NPress file = $S",localFilename)
if transmitFlag & waitFlag then WaitForJob()
FinishUp()
]

//----------------------------------------------------
and FinishUp() be
//----------------------------------------------------
[
if transmitFlag then GetPrinterStatus(dsp)
finish
]

//----------------------------------------------------
and SendToPrinter(inputStream, lastPage, useBreakName) be
//----------------------------------------------------
[
Wss(dsp,"*NTransmission proceeding")
let buffer = Allocate(sysZone,256)
let eftpSoc = vec lenEFTPSoc
let itWentOK = nil
[
itWentOK = true
OpenEFTPSoc(eftpSoc,0,printerPort)
[
let status = GetPrinterStatus(statusStream, true)
if status eq psSpoolingAndWaiting
% status eq psNotResponding break
Ws("*NPrinter not responding")
SendBlock(eftpSoc, buffer, 0)//wake up spooler
CloseEFTPSoc(eftpSoc)//reset to packet 0
OpenEFTPSoc(eftpSoc,0,printerPort)
] repeat
Resets(inputStream)
if printerUnderstandsPLists then
[
let bytes = GenPrintInstance(buffer,lastPage)
itWentOK = SendBlock(eftpSoc, buffer, bytes)
]
for page = 1 to lastPage do
[
unless itWentOK break
ReadBlock(inputStream,buffer,256)
if page eq lastPage then fillInDDV(buffer,useBreakName)
itWentOK = SendBlock(eftpSoc, buffer, 512)
]
if itWentOK then SendEFTPEnd(eftpSoc,500)
CloseEFTPSoc(eftpSoc)
] repeatuntil itWentOK
Wss(dsp,"...Done")
Free(sysZone,buffer)
GetPrinterStatus(statusStream)
]

//----------------------------------------------------
and SendBlock(eftpSoc, buffer, bytes) = valof
//----------------------------------------------------
[
let longRetryCount = 12
[
let length = SendEFTPBlock(eftpSoc,buffer,bytes,500)
switchon length into
[
default: if length eq bytes break; endcase
case EFTPTimeout:
[
Ws("*NPrinter not responding")
test eftpSoc>>EFTPSoc.SeqNum eq 0
ifso resultis false
ifnot
[
longRetryCount = longRetryCount -1
if longRetryCount eq 0 then docase 513
]
endcase
]
case EFTPAbortReceived:
[
let pbi = GetEFTPAbort(eftpSoc)
Resets(statusStream); Puts(statusStream,$*N)
for i = 3 to pbi>>PBI.pup.length-pupOvBytes do
Puts(statusStream,pbi>>PBI.pup.bytes↑i)

]
]
case 513:
[
Ws("Something is wrong. I’ll restart and try again")
resultis false
]
]
] repeat
resultis true
]

//----------------------------------------------------
and fillInDDV(ddv,useBreakName) be
//----------------------------------------------------
[
let s = lv(ddv>>DDV.FileStr)
if s>>String.length eq 0
then MoveBlock(s,
(useBreakName? breakPageName, headerName),
size DDV.FileStr/16)

s = lv(ddv>>DDV.CreatStr)
unless printerUnderstandsPLists
do MoveBlock(s, printedBy, size DDV.CreatStr/16)

s = lv(ddv>>DDV.DateStr)
if s>>String.length eq 0
then MoveBlock(s, headerDate, size DDV.DateStr/16)

if forceDate&(ddv>>DDV.date0 eq 0 % ddv>>DDV.date0 eq -1) then
ReadCalendar(lv ddv>>DDV.date)

if ddv>>DDV.lCopy eq ddv>>DDV.fCopy
then ddv>>DDV.lCopy = ddv>>DDV.fCopy+numCopies-1
]

//----------------------------------------------------
and GetPrinterStatus(stream, getCapabilities; numargs N) = valof
//----------------------------------------------------
// Returns the status word in the response, or 0 if no response
[ if N ls 2 then getCapabilities = false
if stream eq statusStream then Resets(stream)
let statusPort = vec lenPort; MoveBlock(statusPort,printerPort,lenPort)
statusPort>>Port.socket↑1 = 0
statusPort>>Port.socket↑2 = socketPrinterStatus
let soc = vec lenPupSoc
OpenLevel1Socket(soc,0,statusPort)

let pbi = TryForReply(soc, typePrinterStatusRequest,
typePrinterStatusReply,GetPBI,pupOvBytes)
unless pbi do
[
CloseLevel1Socket(soc)
resultis 0
]
Puts(stream,$*N)
for i = 3 to pbi>>PBI.pup.length-pupOvBytes do
Puts(stream,pbi>>PBI.pup.bytes↑i)
let status = pbi>>PBI.pup.words↑1
ReleasePBI(pbi)

if getCapabilities then
[
let pbi = TryForReply(soc, typePrCapabilityRequest,
typePrCapabilityReply,GetPBI,pupOvBytes)
if pbi then
[
printerUnderstandsPLists = true
ParsePrinterCapabilities(pbi)
ReleasePBI(pbi)
]
]
CloseLevel1Socket(soc)
resultis status
]

//----------------------------------------------------
and TryForReply(soc,type,replyType,pbiRoutine,length) = valof
//----------------------------------------------------
[
for i = 1 to 5 do
[
CompletePup(pbiRoutine(soc),type,length)
let timer = nil; SetTimer(lv timer,20)
Block() repeatuntil soc>>PupSoc.iQ.head ne 0
% TimerHasExpired(lv timer)
let pbi = Dequeue(lv soc>>PupSoc.iQ)
if pbi ne 0 then
[
if pbi>>PBI.pup.type eq replyType resultis pbi
ReleasePBI(pbi)
]
]
resultis 0
]

//----------------------------------------------------
and PrinterCapability(name, value) = valof
//----------------------------------------------------
[
if StringCompare(name, "DUPLEX") eq 0 then
[
printerDouble = StringCompare(value, "TRUE") eq 0
resultis true
]
if StringCompare(name, "COLOR") eq 0 then
[
printerColor = StringCompare(value, "TRUE") eq 0
resultis true
]
if StringCompare(name, "ID") eq 0 then
[
unless printInstanceID
do printInstanceID = Allocate(sysZone, 2)
unless Nin(value, printInstanceID, true)
do Zero(printInstanceID, 2)
resultis true
]
if StringCompare(name, "MAX-FILE-SIZE") eq 0 then
[
unless Nin(value, lv printerMaxFile)
do Zero(printerMaxFile, 2)
resultis true
]
if StringCompare(name, "CURRENT-FILE-SIZE") eq 0 then
[
unless Nin(value, lv printerCurrentFile)
do Zero(printerCurrentFile, 2)
resultis true
]
resultis true
]

//----------------------------------------------------
and ParsePrinterCapabilities(pbi) = valof
//----------------------------------------------------
[
let s = vec lFS; InitPListStream(s, lv pbi>>PBI.pup.bytes,
pbi>>PBI.pup.length-pupOvBytes)
resultis ScanPList(s,PrinterCapability)
]

//----------------------------------------------------
and GenPrintInstance(buf, fileSize) = valof
//----------------------------------------------------
[
Zero(buf, 256); buf!0, buf!1 = PrInstPass0,PrInstPass1
let s = vec lFS; InitPListStream(s, buf+2, 508)
Puts(s, $( )
WriteStringProp(s, "PRINTED-BY", UserName)
WriteStringProp(s, "PRINTED-FOR", (forName? forName, UserName))
if password then WriteStringProp(s, "HOLD", password)
if printInstanceID then WriteNumberProp(s, "ID", printInstanceID, true)
if forceDuplex then WriteBooleanProp(s, "DUPLEX", duplex)
WriteNumberProp(s, "FILE-PAGES", fileSize)
Puts(s, $) )
resultis Stateofs(s)+4 //stream position + password overhead
]

//----------------------------------------------------
and JobStatus(name, value) = valof
//----------------------------------------------------
[
if StringCompare(name, "STATUS") eq 0 then Wss(dsp, value)
resultis true
]

//----------------------------------------------------
and ParseJobStatus(pbi) = valof
//----------------------------------------------------
[
let s = vec lFS; InitPListStream(s, lv pbi>>PBI.pup.bytes,
pbi>>PBI.pup.length-pupOvBytes)
resultis ScanPList(s,JobStatus)
]

//----------------------------------------------------
and GetJobPBI(soc) = valof
//----------------------------------------------------
[
let pbi = GetPBI(soc)
MoveBlock(lv pbi>>PBI.pup.bytes, printInstanceID, 2)
resultis pbi
]

//----------------------------------------------------
and WaitForJob() be
//----------------------------------------------------
[
Resets(keys)
let statusPort = vec lenPort; MoveBlock(statusPort,printerPort,lenPort)
statusPort>>Port.socket↑1 = 0
statusPort>>Port.socket↑2 = socketPrinterStatus
let soc = vec lenPupSoc
OpenLevel1Socket(soc,0,statusPort)
[
Wss(dsp, "*NPress <RETURN> for status, <DEL> to quit.*N")
let ch = Gets(keys)
if ch eq DEL break
let pbi = printInstanceID?
TryForReply(soc, typeJobStatusRequest,
typeJobStatusReply,GetJobPBI,pupOvBytes+4),
0
test pbi
ifso
[
ParseJobStatus(pbi)
ReleasePBI(pbi)
]
ifnot Wss(dsp, "No response")
GetPrinterStatus(statusStream)
] repeat
CloseLevel1Socket(soc)
]

//----------------------------------------------------
and GetDateAndTime(pupPackageEnabled) = valof
//----------------------------------------------------
[
let dateString = Allocate(sysZone,20); Zero(dateString,20)
compiletest alto
ifso [ CONVUDT(dateString,0) ]
ifnot
[
unless pupPackageEnabled resultis dateString
let soc = vec lenPupSoc
OpenLevel1Socket(soc,0,table [ 0; 0; socketMiscServices ])
for i = 1 to 5 do
[
CompletePup(GetPBI(soc),typeStringTimeRequest,pupOvBytes)
let timer = nil; SetTimer(lv timer,20)
Block() repeatuntil soc>>PupSoc.iQ.head ne 0 %
TimerHasExpired(lv timer)
let pbi = Dequeue(lv soc>>PupSoc.iQ); if pbi eq 0 loop
let ok = pbi>>PBI.pup.type eq typeStringTimeReply
if ok then
[
dateString>>String.length = pbi>>PBI.pup.length-pupOvBytes
for i = 1 to dateString>>String.length do
dateString>>String.char↑i = pbi>>PBI.pup.bytes↑i
]
ReleasePBI(pbi)
if ok break
]
CloseLevel1Socket(soc)
]
resultis dateString
]