From 7553b7f9d4dddc2235c137d41de8ce22547bebe3 Mon Sep 17 00:00:00 2001 From: Camil Staps Date: Wed, 1 Jul 2015 17:36:37 +0200 Subject: Initial commit --- osprint.icl | 494 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 494 insertions(+) create mode 100644 osprint.icl (limited to 'osprint.icl') 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) -- cgit v1.2.3