diff options
Diffstat (limited to 'osprint.icl')
| -rw-r--r-- | osprint.icl | 494 |
1 files changed, 494 insertions, 0 deletions
diff --git a/osprint.icl b/osprint.icl new file mode 100644 index 0000000..c56d54a --- /dev/null +++ b/osprint.icl @@ -0,0 +1,494 @@ +implementation module osprint
+
+import StdArray, StdBool, StdEnum, StdFile, StdFunc, StdInt, StdList, StdMisc, StdTuple
+import clCCall_12,clCrossCall_12, iostate, scheduler
+import ospicture, osevent, StdWindow, StdPSt
+import code from "cCrossCallPrinter_121.o",
+ "cprinter_121.o"
+
+:: PrintSetup
+ = { devmode :: !String
+ , device :: !String // device, driver & output strings are null terminated
+ , driver :: !String
+ , output :: !String
+ }
+:: JobInfo
+ = { range :: !(!Int,!Int)
+ , copies :: !Int
+ }
+:: PrintInfo
+ = { printSetup :: PrintSetup
+ , jobInfo :: JobInfo
+ }
+:: Alternative x y
+ = Cancelled x
+ | StartedPrinting y
+
+
+os_installprinter :: !*OSToolbox -> *OSToolbox
+os_installprinter _
+ = code
+ {
+ .inline InstallCrossCallPrinter
+ ccall InstallCrossCallPrinter "I-I"
+ .end
+ }
+
+
+os_getpagedimensions :: !PrintSetup !Bool -> (!(!Int,!Int), !(!(!Int,!Int),!(!Int,!Int)), !(!Int,!Int))
+os_getpagedimensions { devmode, device, driver } emulateScreenRes
+ = os_getpagedimensionsC devmode device driver emulateScreenRes
+
+os_defaultprintsetup :: !*env -> (!PrintSetup, !*env)
+os_defaultprintsetup env
+ # (dmSize,printerHandle,device,driver,output,env) = getDevmodeSizeC env
+ | dmSize==0
+ = ({devmode="\0", device="\0", driver="\0", output="\0"},env)
+ # devmode = createArray dmSize ' '
+ devmode = { devmode & [dec dmSize]='\0'}
+ env = getDefaultDevmodeC devmode printerHandle device env // alters contents of printSetup
+ = ({devmode=devmode, device=device, driver=driver, output=output}, env)
+
+printSetupDialogBoth :: !PrintSetup !(Maybe *Context) -> (!PrintSetup, !Maybe *Context)
+printSetupDialogBoth print_setup=:{devmode,device,driver,output} mb_context
+ # (os, mb_context) = EnvGetOS mb_context
+ # os = os_installprinter os
+ # (devmodePtr,os) = winMakeCString devmode os
+ # (devicePtr, os) = winMakeCString device os
+ # (driverPtr, os) = winMakeCString driver os
+ # (outputPtr, os) = winMakeCString output os
+ # (ok, pdPtr, mb_context, os) = CCPrintSetupDialog mb_context (size devmode) devmodePtr devicePtr driverPtr outputPtr os
+ # os = winReleaseCString devmodePtr os
+ # os = winReleaseCString devicePtr os
+ # os = winReleaseCString driverPtr os
+ # os = winReleaseCString outputPtr os
+ | ok==0
+ # os = release_memory_handles pdPtr os
+ = (print_setup, EnvSetOS os mb_context)
+ | otherwise
+ # ((ndevmode,ndevice,ndriver,noutput),os)
+ = get_printSetup_with_PRINTDLG pdPtr os
+ # os = release_memory_handles pdPtr os
+ = ({devmode=ndevmode,device=ndevice,driver=ndriver,output=noutput}, EnvSetOS os mb_context)
+
+os_printsetupvalid :: !PrintSetup !*env -> (!Bool, !*env)
+os_printsetupvalid {devmode,device,driver} env
+ = os_printsetupvalidC devmode device driver env
+
+os_printsetupvalidC :: !String !String !String!*env -> (!Bool, !*env)
+os_printsetupvalidC _ _ _ _
+ = code
+ {
+ ccall os_printsetupvalidC "SSS:I:A"
+ }
+
+class PrintEnvironments printEnv where
+ os_printpageperpage :: !Bool !Bool
+ !.x
+ .(.x -> .(PrintInfo -> .(*Picture -> *((.Bool,Point2),*(.state,*Picture)))))
+ (*(.state,*Picture) -> *((.Bool,Point2),*(.state,*Picture)))
+ !PrintSetup !*printEnv
+ -> (Alternative .x .state,!*printEnv)
+ os_printsetupdialog :: !PrintSetup !*printEnv
+ -> (!PrintSetup,!*printEnv)
+
+
+instance PrintEnvironments (PSt .l) where
+ os_printpageperpage doDialog emulateScreen x initFun transFun printSetup pSt=:{io}
+ #! (windowStack, io) = getWindowStack io
+ windowStackIds = map fst windowStack
+ (zippedWithSelectState, io) = seqList (map zipWithSelectState windowStackIds) io
+ activeWindowIds = [ id \\ (mbSelectState, id) <- zippedWithSelectState | isEnabled mbSelectState]
+ io = seq (map disableWindow activeWindowIds) io
+ (result, pSt) = accContext accFun { pSt & io=io }
+ pSt = appPIO (seq (map enableWindow activeWindowIds)) pSt
+ = (result, pSt)
+ where
+ accFun context
+ # (os, context) = EnvGetOS context
+ # os = os_installprinter os
+ # (x,mb_context,os) = printPagePerPageBothSemaphor
+ doDialog emulateScreen x initFun transFun printSetup (Just context) os
+ = (x,EnvSetOS os (fromJust mb_context))
+
+ zipWithSelectState :: Id (IOSt .l) -> (v:(Maybe SelectState,Id),IOSt .l)
+ zipWithSelectState id io
+ #! (mbSelectState, io) = getWindowSelectState id io
+ = ((mbSelectState, id), io)
+
+ isEnabled (Just Able) = True
+ isEnabled _ = False
+
+ os_printsetupdialog printSetup pSt
+ = accContext (accFun printSetup) pSt
+ where
+ accFun printSetup context
+ # (printSetup, Just context) = printSetupDialogBoth printSetup (Just context)
+ = (printSetup, context)
+
+
+
+instance PrintEnvironments Files where
+ os_printpageperpage doDialog emulateScreen x initFun transFun printSetup files
+ # (os, files) = EnvGetOS files
+ # os = os_installprinter os
+ # (x,_,os) = printPagePerPageBothSemaphor
+ doDialog emulateScreen x initFun transFun printSetup Nothing os
+ = (x, EnvSetOS os files)
+
+ os_printsetupdialog printSetup files
+ # (printSetup, _) = printSetupDialogBoth printSetup Nothing
+ = (printSetup, files) // oh lala
+
+
+printPagePerPageBothSemaphor :: !Bool !Bool .a
+ .(.a -> .(.PrintInfo -> .(*Picture -> *((Bool,Origin),*(.b,*Picture)))))
+ (*(.b,*Picture) -> *((Bool,Origin),*(.b,*Picture)))
+ !PrintSetup *(Maybe *Context) !*OSToolbox
+ -> *(*(Alternative .a .b),*(Maybe *Context),!*OSToolbox)
+printPagePerPageBothSemaphor p1 p2 x p4 p5 printSetup mb_context os
+// with this mechanism it is assured, that only one print job can happen at a time
+// addSemaphor adds the parameter to a C global and gives back the previous value of that
+// global
+ # (s,os) = addSemaphor 1 os
+ | s>0
+ # (_,os) = addSemaphor (-1) os
+ = (Cancelled x,mb_context,os)
+ # (result,mb_context,os) = printPagePerPageBoth p1 p2 x p4 p5 printSetup mb_context os
+ (_,os) = addSemaphor (-1) os
+ = (result,mb_context,os)
+
+printPagePerPageBoth :: !Bool !Bool .a
+ .(.a -> .(.PrintInfo -> .(*Picture -> *((Bool,Origin),*(.b,*Picture)))))
+ (*(.b,*Picture) -> *((Bool,Origin),*(.b,*Picture)))
+ PrintSetup *(Maybe *Context) !*OSToolbox
+ -> *(*(Alternative .a .b),*(Maybe *Context),!*OSToolbox)
+printPagePerPageBoth doDialog emulateScreen x initFun transFun printSetup mb_context os
+ // do the print dialog (or not) and get the hdc and the printInfo
+
+ # (err, hdc, printInfo, mb_context, os)
+ = getPrintInfo doDialog emulateScreen printSetup mb_context os
+
+ | err == 4107 // this error occurs, when the printsetup contains bad values
+ # (defaultPS, os) = os_defaultprintsetup os
+ = printPagePerPageBoth doDialog emulateScreen x initFun transFun defaultPS mb_context os
+
+ // check, whether the user canceled
+
+ | err >= 0 = (Cancelled x, mb_context, os)
+
+ // call StartDoc either via the OS thread or direct
+
+ # (err, mb_context, os) = CCstartDoc hdc mb_context os
+
+ | err <= 0 = (Cancelled x, mb_context, deleteDC hdc os)
+ // user canceled printing to file from file dialog
+
+ // initialise printer picture and call the initFun function
+
+ # picture = initPicture zeroOrigin (hdc,os)
+ (endOrig,(initState,picture)) = initFun x printInfo picture
+ (_,_,_,hdc,os) = unpackPicture picture
+
+ // now print all pages
+
+ # (finalState,hdc,mb_context,os)
+ = printPages 0 transFun endOrig initState hdc mb_context os
+
+ // Sluit af
+
+ (mb_context, os) = CCendDoc hdc mb_context os
+ = (StartedPrinting finalState, mb_context, (deleteDC hdc os))
+
+printPages :: Int
+ (*(.a,*Picture) -> *((Bool,Origin),* (.a,*Picture)))
+ (Bool,Origin) .a HDC *(Maybe *Context) !*OSToolbox
+ -> *(.a,HDC,*(Maybe *Context),!*OSToolbox)
+printPages _ _ (True,_) state hdc mb_context os
+ =(state,hdc,mb_context,os)
+printPages pageNr fun (_,origin) state hdc mb_context os
+
+ // give OS thread eventually a chance to handle events
+ # (mb_context,os) = evtlSwitchToOS pageNr hdc mb_context os
+
+ # (ok, os) = startPage hdc os
+ | ok == 0 = abort "\nPrint08: Failed in \"StartPage\". Probably not enough memory."
+ # picture = initPicture origin (hdc,os)
+ // apply drawfunctions contained in this page
+ ((endOfDoc,nextOrigin),(state`,picture)) = fun (state,picture)
+ // finish drawing
+ # (_,_,_,hdc,os) = unpackPicture picture
+ (ok, os) = endPage hdc os
+ // (not ok) should not cause an abort, because endPage returns an error, when user chooses
+ // "encapsulated postscript" as output format and the output is longer than one page.
+ // This situation can't be retrieved from the "GetLastError" code. An abort should not occur.
+ (canceled,os) = wasCanceled os
+ // draw rest of pages
+ = printPages (inc pageNr) fun (endOfDoc || canceled || (ok==0),nextOrigin) state` hdc mb_context os
+
+zeroOrigin :== zero
+
+///////////////////////////////////////////////////////////////////////////////
+
+getPrintInfo :: !.Bool !.Bool .PrintSetup *(Maybe *Context) !*OSToolbox
+ -> *(Int,Int,.PrintInfo,*Maybe *Context,!.OSToolbox);
+getPrintInfo doDialog emulateScreen {devmode, device, driver, output} mb_context os
+ # (devmodePtr,os) = winMakeCString devmode os
+ (devicePtr,os) = winMakeCString device os
+ (driverPtr,os) = winMakeCString driver os
+ (outputPtr,os) = winMakeCString output os
+ ( err, data, pdPtr, mb_context, os)
+ = CCgetDC (if doDialog 1 0) (if emulateScreen 2 0) // these two bits will be packed into one word in CCgetDC
+ (size devmode) devmodePtr devicePtr driverPtr outputPtr mb_context os
+ os = winReleaseCString devmodePtr os
+ os = winReleaseCString devicePtr os
+ os = winReleaseCString driverPtr os
+ os = winReleaseCString outputPtr os
+ | doDialog && (err==(-1))
+ # (setup_strings, os) = get_printSetup_with_PRINTDLG pdPtr os
+ os = release_memory_handles pdPtr os
+ = continuation err data mb_context (setup_strings, os)
+ = continuation err data mb_context ((devmode,device,driver,output),os)
+ where
+ continuation err (first,last,copies,hdc) mb_context ((devmode,device,driver,output),os)
+ # first` = max 1 first
+ last` = max first` last
+ copies` = max 1 copies
+ = ( err,
+ hdc,
+ { printSetup = { devmode=devmode, device=device ,driver=driver, output=output },
+ jobInfo = { range = (first`,last`),
+ copies = copies`
+ }
+ },
+ mb_context,
+ os
+ )
+
+handleContextOSEvent` :: !OSEvent !Context !*OSToolbox -> (!CrossCallInfo,!Context,!*OSToolbox)
+handleContextOSEvent` osEvent context tb
+ # (return,context) = handleContextOSEvent osEvent context
+ = (setReplyInOSEvent return,context,tb)
+
+
+CCgetDC :: !.Int !.Int !.Int !.Int !.Int !.Int !.Int !*(Maybe *Context) !*OSToolbox -> *(!Int,!(!Int,!Int,!Int,!Int),!Int,!*Maybe *Context,!.OSToolbox);
+CCgetDC doDialog emulateScreen devmodeSize devmodePtr devicePtr driverPtr outputPtr Nothing os
+ # (ok,first,last,copies,pdPtr,deviceContext,os)
+ = getDC doDialog emulateScreen 1 devmodeSize devmodePtr devicePtr driverPtr outputPtr os
+ = (ok,(first,last,copies,deviceContext),pdPtr,Nothing,os)
+CCgetDC doDialog emulateScreen devmodeSize devmodePtr devicePtr driverPtr outputPtr (Just context) os
+ # createcci = Rq6Cci CcRqGET_PRINTER_DC (doDialog bitor emulateScreen) devmodeSize
+ devmodePtr devicePtr driverPtr outputPtr
+ # (rcci, context, os) = issueCleanRequest handleContextOSEvent` createcci context os
+ = ( rcci.p1, (rcci.p2, rcci.p3, rcci.p4,rcci.p6), rcci.p5,
+////////err, (first, last, copies, deviceContext),pdPtr,
+ Just context,os
+ )
+
+CCPrintSetupDialog :: !(Maybe *Context) !.Int !.Int !.Int !.Int !.Int !*OSToolbox -> (!OkReturn,!Int,!Maybe *Context, !.OSToolbox);
+CCPrintSetupDialog nothing=:Nothing devmodeSize devmodePtr devicePtr driverPtr outputPtr os
+ # (ok, pdPtr, os) = printSetup 1 devmodeSize devmodePtr devicePtr driverPtr outputPtr os
+ = (ok, pdPtr, nothing, os)
+CCPrintSetupDialog (Just context) devmodeSize devmodePtr devicePtr driverPtr outputPtr os
+ # createcci = Rq5Cci CcRqDO_PRINT_SETUP devmodeSize devmodePtr devicePtr driverPtr outputPtr
+ (rcci, context, os) = issueCleanRequest handleContextOSEvent` createcci context os
+ = (rcci.p1, rcci.p2, Just context, os)
+/* MW was
+CCPrintSetupDialog :: !.Bool .Int .Int .Int .Int .Int !*OSToolbox -> (OkReturn,Int,!.OSToolbox);
+CCPrintSetupDialog True devmodeSize devmodePtr devicePtr driverPtr outputPtr os
+ = printSetup 1 devmodeSize devmodePtr devicePtr driverPtr outputPtr os
+CCPrintSetupDialog False devmodeSize devmodePtr devicePtr driverPtr outputPtr os
+ # createcci = Rq5Cci CcRqDO_PRINT_SETUP devmodeSize devmodePtr devicePtr driverPtr outputPtr
+ (rcci, os) = issueCleanRequest2 (ErrorCallback2 "ERROR in osPrint08") createcci os
+ (rcci, os) = issueCleanRequest2 handleContextOSEvent` createcci os
+ = (rcci.p1, rcci.p2, os)
+*/
+
+CCstartDoc :: !.HDC !*(Maybe *Context) !*OSToolbox -> *(!Int,!*Maybe *Context,!*OSToolbox)
+// error code: -1:no error, 0: user canceled file dialog, others: other error
+CCstartDoc hdc Nothing os
+ # (err,os) = startDoc hdc os
+ = (err,Nothing,os)
+CCstartDoc hdc (Just context) os
+ # createcci = Rq1Cci CcRqSTARTDOC hdc
+ (rcci,context, os) = issueCleanRequest handleContextOSEvent` createcci context os
+ = (rcci.p1, Just context, os)
+
+CCendDoc :: !.HDC !*(Maybe *Context) !*OSToolbox -> *(!*Maybe *Context,!*OSToolbox)
+CCendDoc hdc Nothing os
+ # os = endDoc hdc os
+ = (Nothing,os)
+CCendDoc hdc (Just context) os
+ # createcci = Rq1Cci CcRqENDDOC hdc
+ (_,context, os) = issueCleanRequest handleContextOSEvent` createcci context os
+ = (Just context,os)
+
+evtlSwitchToOS :: !Int !.Int !*(Maybe *Context) !*OSToolbox -> *(!*Maybe *Context,!.OSToolbox)
+evtlSwitchToOS _ _ Nothing os
+ = (Nothing,os)
+evtlSwitchToOS pageNr hdc (Just context) os
+ # nrStr = toString pageNr
+ # messageText = if (pageNr==0) ""
+ (nrStr+++" page"+++(if (pageNr==1) "" "s")+++" printed")
+ # (textPtr,os) = winMakeCString messageText os
+ # createcci = Rq1Cci CcRqDISPATCH_MESSAGES_WHILE_PRINTING textPtr
+ # (_,context, os) = issueCleanRequest handleContextOSEvent` createcci context os
+ # os = winReleaseCString textPtr os
+ = (Just context, os)
+
+initPicture :: !.Origin !*(!.OSPictContext,!*OSToolbox) -> *Picture
+initPicture origin intPict
+ = packPicture origin defaultPen False (fst intPict) (snd intPict)
+
+
+EnvGetOS :: !*env -> (!*OSToolbox,!*env)
+EnvGetOS env
+ = (42,env)
+
+EnvSetOS :: !*OSToolbox !*env -> *env
+EnvSetOS os env
+ = env
+
+
+//////////////////////////////////////////////////
+// //
+// C CALLING FUNCTIONS //
+// //
+//////////////////////////////////////////////////
+
+:: OkReturn :== Int // okReturn<>0 <=> ok !
+
+os_getpagedimensionsC :: !String !String !String !Bool
+ -> (!(!Int,!Int), !(!(!Int,!Int),!(!Int,!Int)), !(!Int,!Int))
+os_getpagedimensionsC _ _ _ _
+ = code
+ {
+ ccall os_getpagedimensionsC "SSSI-IIIIIIII"
+ }
+
+getDevmodeSizeC :: !*env -> (!Int,!Int,!String,!String,!String,!*env)
+getDevmodeSizeC _
+ = code
+ {
+ ccall getDevmodeSizeC ":VIISSS:A"
+ }
+
+getDefaultDevmodeC :: !String !Int !String !*env -> *env
+getDefaultDevmodeC _ _ _ _
+ = code
+ {
+ ccall getDefaultDevmodeC "SIS:V:A"
+ }
+
+printSetup :: !Int !Int !Int !Int !Int !Int !*OSToolbox -> (!OkReturn,!Int,!*OSToolbox)
+printSetup _ _ _ _ _ _ _
+ = code
+ {
+ ccall printSetup "IIIIII:VII:I"
+ }
+
+get_printSetup_with_PRINTDLG :: !Int !*OSToolbox -> (!(!String, !String, !String, !String), !*OSToolbox)
+get_printSetup_with_PRINTDLG _ _
+ = code
+ {
+ ccall get_printSetup_with_PRINTDLG "I:VSSSS:I"
+ }
+
+release_memory_handles :: !Int !*OSToolbox -> *OSToolbox
+release_memory_handles _ _
+ = code
+ {
+ ccall release_memory_handles "II-I"
+ }
+
+startPage :: !HDC !*OSToolbox -> (!OkReturn, !*OSToolbox)
+startPage _ _
+ = code
+ {
+ ccall startPage "I:I:I"
+ }
+
+endPage :: !HDC !*OSToolbox -> (!OkReturn, !*OSToolbox)
+endPage _ _
+ = code
+ {
+ ccall endPage "I:I:I"
+ }
+
+startDoc :: !HDC !*OSToolbox -> (!Int, !*OSToolbox)
+ // err code: >0:no error, <=0: user cancelled file dialog
+startDoc _ _
+ = code
+ {
+ ccall startDoc "I:I:I"
+ }
+
+endDoc :: !HDC !*OSToolbox -> *OSToolbox
+endDoc _ _
+ = code
+ {
+ ccall endDoc "I:V:I"
+ }
+
+wasCanceled :: !*OSToolbox -> (!Bool,!*OSToolbox)
+wasCanceled _
+ = code
+ {
+ ccall wasCanceled ":I:I"
+ }
+
+deleteDC :: !HDC !*OSToolbox -> *OSToolbox
+deleteDC _ _
+ = code
+ {
+ ccall deleteDC "I:V:I"
+ }
+
+
+getDC :: !Int !Int !Int !Int !Int !Int !Int !Int !*OSToolbox -> (!Int, !Int, !Int, !Int, !Int, !Int, !*OSToolbox)
+// getDC doDialog emulateScreen "getDC called directly from CleanThread" devmodeSize
+// first element of result is an error code:
+// -1:no error, others: non fatal error
+getDC _ _ _ _ _ _ _ _ _
+ = code
+ {
+ ccall getDC "IIIIIIII:VIIIIII:I"
+ }
+
+addSemaphor :: !Int !*OSToolbox -> (!Int,!*OSToolbox)
+addSemaphor _ _
+ = code
+ {
+ ccall addSemaphor "I:I:I"
+ }
+
+os_printsetuptostring :: !PrintSetup -> String
+os_printsetuptostring {devmode, device, driver, output}
+ = toString (size devmode)+++" "+++toString (size device)+++" "+++toString (size driver)+++" "
+ +++devmode+++device+++driver+++output
+
+os_stringtoprintsetup :: !String -> PrintSetup
+os_stringtoprintsetup string
+ #! chList = [ch \\ ch<-:string]
+ (sizeChLists, rest) = seqList (repeatn 3 (splitInt [])) chList
+ sizes = map (toInt o toString) sizeChLists
+ (devmodeSize, deviceSize, driverSize) = listTo3Tuple sizes
+ devmode = toString (rest % (0, devmodeSize-1))
+ driverStartIndex = devmodeSize+deviceSize
+ device = toString (rest % (devmodeSize, driverStartIndex-1))
+ outputStartIndex = driverStartIndex+driverSize
+ driver = toString (rest % (driverStartIndex, outputStartIndex-1))
+ output = toString (rest % (outputStartIndex, (size string)-1))
+ | size devmode==devmodeSize && size device==deviceSize
+ && size driver==driverSize && size output==(length rest)-outputStartIndex
+ && devmodeSize>0 && deviceSize>0 && driverSize>0 && size output>0
+ = {devmode=devmode, device=device, driver=driver, output=output}
+ = {devmode="\0", device="\0", driver="\0", output="\0"}
+ where
+ splitInt akku []
+ = (reverse akku, [])
+ splitInt akku [ch:chs]
+ | isDigit ch
+ = splitInt [ch:akku] chs
+ = (reverse akku, chs)
+ listTo3Tuple [e1,e2,e3] = (e1,e2,e3)
|