suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

remove MysterX DLL, replace with wrapper around `ffi/com'

Browse Source 
The ActiveX part of MysterX is gone. The `ffi/com' re-imeplemtnation
provides only core COM support.

The "mysssink" DLL is still needed, and its source is still
in the tree, but it is downloaded in the same way as other
pre-built DLLs. The DLL no longer needs to be registered with
regsvr32.
This commit is contained in:
Matthew Flatt 2012-02-16 15:02:37 -07:00
parent 566e9bb8bf
commit 11de33d4ff
111 changed files with 451 additions and 28040 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
Racket.suo Normal file
View File

Binary file not shown.

75
collects/ffi/unsafe/com.rkt
View File

@ -4,6 +4,7 @@
ffi/winapi
ffi/unsafe/atomic
racket/date
racket/runtime-path
(for-syntax racket/base)
"private/win32.rkt")
@ -117,24 +118,13 @@
;; ----------------------------------------
;; Manual memory management and strings
(define (utf-16-length s)
(for/fold ([len 0]) ([c (in-string s)])
(+ len
(if ((char->integer c) . > . #xFFFF)
2
1))))
(define _system-string/utf-16
(make-ctype _pointer
(lambda (s)
(and s
(let ([v (malloc _gcpointer)])
(ptr-set! v _string/utf-16 s)
(let ([p (ptr-ref v _gcpointer)])
(let ([len (utf-16-length s)])
(let ([c (SysAllocStringLen p len)])
(register-cleanup! (lambda () (SysFreeString c)))
c))))))
(let ([c (string->pointer s)])
(register-cleanup! (lambda () (SysFreeString c)))
c)))
(lambda (p) (cast p _pointer _string/utf-16))))
(define current-cleanup (make-parameter #f))
@ -326,14 +316,14 @@
;; ITypeInfo
(define-com-interface (_ITypeInfo _IUnknown)
([GetTypeAttr (_hmfun (p : (_ptr o _TYPEATTR-pointer))
([GetTypeAttr (_hmfun (p : (_ptr o _TYPEATTR-pointer/null))
-> GetTypeAttr p)
#:release-with-method ReleaseTypeAttr]
[GetTypeComp _fpointer]
[GetFuncDesc (_hmfun _UINT (p : (_ptr o _FUNCDESC-pointer))
[GetFuncDesc (_hmfun _UINT (p : (_ptr o _FUNCDESC-pointer/null))
-> GetFuncDesc p)
#:release-with-method ReleaseFuncDesc]
[GetVarDesc (_hmfun _UINT (p : (_ptr o _VARDESC-pointer))
[GetVarDesc (_hmfun _UINT (p : (_ptr o _VARDESC-pointer/null))
-> GetVarDesc p)
#:release-with-method ReleaseVarDesc]
[GetNames (_hmfun _MEMBERID (s : (_ptr o _pointer)) ; string
@ -387,12 +377,12 @@
(define-com-interface (_ITypeLib _IUnknown)
([GetTypeInfoCount/tl (_mfun -> _UINT)]
[GetTypeInfo/tl (_hmfun _UINT (p : (_ptr o _ITypeInfo-pointer))
[GetTypeInfo/tl (_hmfun _UINT (p : (_ptr o _ITypeInfo-pointer/null))
-> GetTypeInfo p)
#:release-with-function Release]
[GetTypeInfoType (_hmfun _UINT (p : (_ptr o _TYPEKIND))
-> GetTypeInfoType p)]
[GetTypeInfoOfGuid (_hmfun _REFGUID (p : (_ptr o _ITypeInfo-pointer))
[GetTypeInfoOfGuid (_hmfun _REFGUID (p : (_ptr o _ITypeInfo-pointer/null))
-> GetTypeInfoOfGuid p)
#:release-with-function Release]
[GetLibAttr _fpointer]
@ -408,7 +398,7 @@
(define IID_IProvideClassInfo (string->iid "{B196B283-BAB4-101A-B69C-00AA00341D07}"))
(define-com-interface (_IProvideClassInfo _IUnknown)
([GetClassInfo (_hmfun (p : (_ptr o _ITypeInfo-pointer))
([GetClassInfo (_hmfun (p : (_ptr o _ITypeInfo-pointer/null))
-> GetClassInfo p)
#:release-with-function Release]))
@ -436,10 +426,22 @@
(define-com-interface (_IConnectionPointContainer _IUnknown)
([EnumConnectionPoints _fpointer]
[FindConnectionPoint (_hmfun _REFIID
(p : (_ptr o _IConnectionPoint-pointer))
(p : (_ptr o _IConnectionPoint-pointer/null))
-> FindConnectionPoint p)
#:release-with-function Release]))
;; ----------------------------------------
;; IClassFactory
(define IID_IClassFactory (string->iid "{00000001-0000-0000-C000-000000000046}"))
(define-com-interface (_IClassFactory _IUnknown)
([CreateInstance/factory (_hmfun _IUnknown-pointer/null _REFIID
(p : (_ptr o _ISink-pointer/null))
-> CreateInstance p)]
[LockServer _fpointer]))
;; ----------------------------------------
;; COM object creation
@ -452,7 +454,7 @@
[hr _HRESULT]))
(define-ole CoCreateInstance (_hfun _REFCLSID _pointer _DWORD _REFIID
(p : (_ptr o _IUnknown-pointer))
(p : (_ptr o _IUnknown-pointer/null))
-> CoCreateInstance p)
#:wrap (allocator Release))
@ -640,7 +642,7 @@
(define (com-object-get-unknown obj)
(or (com-object-unknown obj)
(error 'com-object-get-unknown "COM object has been released" obj)))
(error 'com-object-get-unknown "COM object has been released: ~e" obj)))
(define (com-object-get-dispatch obj)
(or (com-object-dispatch obj)
@ -1548,7 +1550,7 @@
(cadr t)
inv-kind
args))
;; from this point, don't exacpe/return without running cleanups
;; from this point, don't escape/return without running cleanups
(define method-result
(if (= inv-kind INVOKE_PROPERTYPUT)
#f
@ -1573,11 +1575,13 @@
(define desc (EXCEPINFO-bstrDescription exn-info))
(windows-error
(if has-error-code?
(format "COM object exception, error code 0x~x~a~a"
(format "COM object exception during ~s, error code 0x~x~a~a"
name
(EXCEPINFO-wCode exn-info)
(if desc "\nDescription: " "")
(or desc ""))
(format "COM object exception~a~a"
(format "COM object exception during ~s~a~a"
name
(if desc "\nDescription: " "")
(or desc "")))
(EXCEPINFO-scode exn-info))]
@ -1658,6 +1662,8 @@
;; ----------------------------------------
;; COM event handlers
(define-runtime-path myssink-dll '(so "myssink.dll"))
(define CLSID_Sink
;; "myssink.dll":
(string->clsid "{DA064DCD-0881-11D3-B5CA-0060089002FF}"))
@ -1722,12 +1728,21 @@
(define connection-point (FindConnectionPoint connection-point-container
(TYPEATTR-guid type-attr)))
(ReleaseTypeAttr type-info type-attr)
;; emulate CoCreateInstance on athe myssink DLL, which avoids the
;; need for registration:
(define myssink-lib (ffi-lib myssink-dll))
(define myssink-DllGetClassObject
(get-ffi-obj 'DllGetClassObject myssink-lib
(_hfun _GUID-pointer _GUID-pointer
(u : (_ptr o _IClassFactory-pointer/null))
-> DllGetClassObject u)))
(define sink-factory
(myssink-DllGetClassObject CLSID_Sink IID_IClassFactory))
(define sink-unknown
(CoCreateInstance CLSID_Sink #f
(bitwise-ior CLSCTX_LOCAL_SERVER CLSCTX_INPROC_SERVER)
IID_IUnknown))
;; This primitive method doesn't AddRef the object,
;; so don't Release it:
(CreateInstance/factory sink-factory #f CLSID_Sink))
(define sink (QueryInterface sink-unknown IID_ISink _ISink-pointer))
(Release sink-unknown)
(set_myssink_table sink myssink-table)
(define cookie (Advise connection-point sink))
(set-com-object-connection-point! obj connection-point)

16
collects/ffi/unsafe/private/win32.rkt
View File

@ -311,7 +311,7 @@
(define (string->guid s [stay-put? #f])
(define guid
(if stay-put?
(cast (malloc _GUID 'atomic-interior) _pointer _GUID-pointer)
(cast (malloc _GUID 'atomic-interior) _pointer (_gcable _GUID-pointer))
(make-GUID 0 0 0 (list 0 0 0 0 0 0 0 0))))
(IIDFromString s guid)
guid)
@ -333,3 +333,17 @@
(define-oleaut SysFreeString (_wfun _pointer -> _void))
(define-oleaut SysAllocStringLen (_wfun _pointer _uint -> _pointer))
(define (utf-16-length s)
(for/fold ([len 0]) ([c (in-string s)])
(+ len
(if ((char->integer c) . > . #xFFFF)
2
1))))
(define (string->pointer s)
(let ([v (malloc _gcpointer)])
(ptr-set! v _string/utf-16 s)
(let ([p (ptr-ref v _gcpointer)])
(let ([len (utf-16-length s)])
(SysAllocStringLen p len)))))

2
collects/meta/build/build
View File

@ -1488,13 +1488,13 @@ DO_WINDOWS_BUILD() {
win_build_step RKT "get-libs (core)" ../src/get-libs.rkt core
win_build_step RKT "get-libs (gui)" ../src/get-libs.rkt gui
win_build_step RKT "get-libs (db)" ../src/get-libs.rkt db
win_build_step RKT "get-libs (com)" ../src/get-libs.rkt com
header -s "Windows: Building libraries"
_cd "$PLTHOME"
win_build_step RKT "compiler" -N raco -l- raco setup -Dl compiler
win_build_step VSNET3M "mzcom"
win_build_step VSNET3M "libmysterx"
_cd "$PLTHOME"; win_build_step RKT "raco setup" $SETUP_ARGS

8
collects/meta/dist-specs.rkt
View File

@ -657,10 +657,10 @@ plt-extras :+= (package: "plot")
plt-extras :+= (- (package: "mzcom" #:src? #t)
(cond (not win) => (src: "")))
;; -------------------- mysterx
plt-extras :+= (- (+ (package: "mysterx" #:src? #t)
(src: "worksp/libmysterx/")
(dll: "myspage" "myssink"))
;; -------------------- com & mysterx
plt-extras :+= (- (+ (dll: "myssink")
(src: "myssink/" "worksp/myssink/")
(package: "mysterx"))
(cond (not win) => (src: "")))
;; -------------------- temporary tool for converting old files

5
collects/meta/props
View File

@ -1130,10 +1130,7 @@ path/s is either such a string or a list of them.
"collects/mrlib/text-string-style-desc.rkt" drdr:command-line (gracket-text "-t" *)
"collects/mysterx" responsible (mflatt)
"collects/mysterx/main.rkt" drdr:command-line (mzc *)
"collects/mysterx/mxdemo.rkt" drdr:command-line (mzc *)
"collects/mysterx/mysterx.rkt" drdr:command-line (mzc *)
"collects/mysterx/private/mxmain.rkt" drdr:command-line (mzc *)
"collects/mysterx/private/prims.rkt" drdr:command-line (mzc *)
"collects/mzcom" responsible (mflatt)
"collects/mzlib/contract.rkt" responsible (robby)
"collects/mzlib/foreign.rkt" responsible (eli)
@ -1542,8 +1539,6 @@ path/s is either such a string or a list of them.
"collects/tests/macro-debugger/tests/collects.rkt" drdr:command-line (gracket-text "-t" *)
"collects/tests/match" responsible (samth)
"collects/tests/mysterx" responsible (mflatt)
"collects/tests/mysterx/dhtmltests.rktl" drdr:command-line #f
"collects/tests/mysterx/mystests.rktl" drdr:command-line #f
"collects/tests/mzcom" responsible (mflatt)
"collects/tests/mzcom/test.rktl" drdr:command-line #f
"collects/tests/net" responsible (jay eli mflatt robby)

3041
collects/mysterx/doc.txt
View File

File diff suppressed because it is too large Load Diff

4
collects/mysterx/info.rkt
View File

@ -1,5 +1,3 @@
#lang setup/infotab
(define post-install-collection "installer.rkt")
(define scribblings '(("scribblings/mysterx.scrbl" (multi-page) (interop))))
(define scribblings '(("scribblings/mysterx.scrbl" (multi-page) (legacy))))

29
collects/mysterx/installer.rkt
View File

@ -1,29 +0,0 @@
(module installer mzscheme
(require mzlib/process
setup/dirs)
(provide post-installer)
(define (post-installer plt-home)
(define (make-dll-path . more)
(and (find-dll-dir)
(apply build-path (find-dll-dir) more)))
(define (warn fmt . args) (apply fprintf (current-error-port) fmt args))
(let* ([dlls '("myspage.dll" "myssink.dll")]
[dll-paths (map make-dll-path dlls)]
[winsys-dir (find-system-path 'sys-dir)]
[regsvr (and winsys-dir (build-path winsys-dir "REGSVR32.EXE"))])
(cond
[(not (eq? (system-type) 'windows))
;; (printf "Warning: can't install MysterX on non-Windows machine\n")
(void)]
[(not (andmap file-exists? dll-paths))
(printf "Warning: MysterX binaries not installed\n")]
[(not winsys-dir)
(printf "Warning: Can't run REGSVR32 on libraries\n")]
[else (parameterize ([current-directory (make-dll-path)])
(for-each
(lambda (dll)
(printf "MysterX: ~a library ~a\n"
(if (eq? 0 (system*/exit-code regsvr "/s" dll))
"Registered" "Unable to register")
dll))
dlls))]))))

215
collects/mysterx/mxdemo.rkt
View File

@ -1,215 +0,0 @@
;;; mxdemo.rkt -- demo program for MysterX
;;; Requires the MSCal Calendar control.
;;; The calendar control is normally installed with
;;; MS Office, but it can also be downloaded from
;;; elsewhere. Look for "mscal.ocx".
(module mxdemo mzscheme
(require mzlib/class)
(require mysterx)
(require mzlib/runtime-path
mzlib/process)
;; Ensure that DLLs are included with the distibution:
(define-runtime-path myspage-dll '(so "myspage"))
(define-runtime-path myssink-dll '(so "myssink"))
;; Register them every time we start:
(system* "regsvr32.exe" "/s" (path->string myspage-dll))
(system* "regsvr32.exe" "/s" (path->string myssink-dll))
; the browser with the calendar
(define calwb (instantiate mx-browser%
() ; no by-position initializers
(label "Calendar control")
(height 400)
(width 350)
(y 100)
(x 100)
(style-options '(scrollbars))))
(define caldoc (send calwb current-document))
(send caldoc insert-html
(string-append
"<H1 id=\"mx-header\">MysterX Demo</H1>"
"<p>"
"<hr>"
"<p>"
(progid->html "MSCAL.Calendar.7" 300 200)
"<p>"
"<H3 id=\"event-header\"></H3>"))
(define cal (car (send caldoc objects)))
; the control panel document
(define ctrlwb (make-object mx-browser% "Control Panel" 180 350 600 300 '()))
(define ctrldoc (send ctrlwb current-document))
(send ctrldoc insert-html
(string-append
"<table align = center>"
"<caption id=\"Caption\"><b>Keypress here</b></caption>"
"<colgroup align=left>"
"<colgroup align=center>"
"<colgroup align=right>"
"<tr>"
"<td><BUTTON id=\"Yesterday\" style=\"color: blue\">&LT----</BUTTON></td>"
"<td><b>Day</b></td>"
"<td><BUTTON id=\"Tomorrow\" style=\"color: red\">----&GT</BUTTON></td>"
"</tr>"
"<tr>"
"<td><BUTTON id=\"Last-month\" style=\"color: green\">&LT----</BUTTON></td>"
"<td><b>Month</b></td>"
"<td><BUTTON id=\"Next-month\" style=\"color: indigo\">----&GT</BUTTON></td>"
"</tr>"
"<tr>"
"<td><BUTTON id=\"Last-year\" style=\"color: yellow\">&LT----</BUTTON></td>"
"<td><b>Year</b></td>"
"<td><BUTTON id=\"Next-year\" style=\"color: purple\">----&GT</BUTTON></td>"
"</tr>"
"</table>"
"<table align=center>"
"<td><BUTTON id=\"Today\">Today</BUTTON></td>"
"</table>"
"<hr>"
"<table align=center>"
"<tr>"
"<td><BUTTON id=\"Hide\">Hide</BUTTON></td>"
"<td><BUTTON id=\"Show\">Show</BUTTON></td>"
"</tr>"
"</table>"
"<table align=center>"
"<td><BUTTON id=\"Rub-me\">Rub me!</BUTTON></td>"
"</table>"
"<table align=center>"
"<td><BUTTON id=\"About\">About</BUTTON></td>"
"</table>"
"<table align=center>"
"<td><BUTTON id=\"Quit\">Quit</BUTTON></td>"
"</table>"
"<p>"
"<table align=center>"
"<td id=\"event-reflector\">Click on the calendar</td>"
"</table>"))
(define reflector (send ctrldoc find-element "TD" "event-reflector"))
(com-register-event-handler
cal "Click"
(lambda ()
(send reflector set-color! 'white)
(send reflector set-background-color! 'blue)
(thread
(lambda ()
(sleep 0.25)
(send reflector set-color! 'black)
(send reflector set-background-color! 'white)))))
(define (quit-handler ev)
(when (send ev click?)
(exit)))
(define (about-handler ev)
(when (send ev click?)
(com-invoke cal "AboutBox")))
(define (hide-handler ev)
(when (send ev click?)
(send calwb show #f)))
(define (show-handler ev)
(when (send ev click?)
(send calwb show #t)))
(define rub-me-handler
(let ([count 0])
(lambda (ev)
(when (send ev mousemove?)
(printf "mousemove #~a, but who's counting?\n" count)
(set! count (add1 count))))))
(define (today-handler ev)
(when (send ev click?)
(com-invoke cal "Today")))
(define (yesterday-handler ev)
(when (send ev click?)
(com-invoke cal "PreviousDay")))
(define (tomorrow-handler ev)
(when (send ev click?)
(com-invoke cal "NextDay")))
(define (last-month-handler ev)
(when (send ev click?)
(com-invoke cal "PreviousMonth")))
(define (next-month-handler ev)
(when (send ev click?)
(com-invoke cal "NextMonth")))
(define (last-year-handler ev)
(when (send ev click?)
(com-invoke cal "PreviousYear")))
(define (next-year-handler ev)
(when (send ev click?)
(com-invoke cal "NextYear")))
(define button-handlers
`(("Quit" ,quit-handler)
("About" ,about-handler)
("Hide" ,hide-handler)
("Show" ,show-handler)
("Rub-me" ,rub-me-handler)
("Today" ,today-handler)
("Yesterday" ,yesterday-handler)
("Tomorrow" ,tomorrow-handler)
("Last-month" ,last-month-handler)
("Next-month" ,next-month-handler)
("Last-year" ,last-year-handler)
("Next-year" ,next-year-handler)))
(send ctrlwb register-event-handler
(send ctrldoc find-element "CAPTION" "Caption")
(lambda (ev)
(when (send ev keypress?)
(printf "ooh that tickles\n"))))
(for-each
(lambda (sym-handler)
(send ctrlwb register-event-handler
(send ctrldoc find-element
"BUTTON" ; tag
(car sym-handler)) ; id
(cadr sym-handler))) ; handler
button-handlers)
(send ctrlwb handle-events)
;; Wait
(sync never-evt))

2684
collects/mysterx/mysterx.rkt
View File

File diff suppressed because it is too large Load Diff

362
collects/mysterx/private/filter.rkt
View File

@ -1,362 +0,0 @@
;;; filter.rkt
(module filter mzscheme
(require mzlib/string
"properties.rkt"
"util.rkt")
(provide
string->filter
filter->string)
(define (alpha-filter-options-validator opt)
(let ([name (car opt)]
[val (cadr opt)])
(case name
[(enabled) #t]
[(finish-opacity opacity)
(exact-with-bounds? val 0 100)]
[(finish-x finish-y)
(and (number? val)
(exact? val))]
[(finish-x finish-y start-x starty-y)
(and (number? val)
(exact? val))]
[(style)
(alpha-filter-style? val)]
[else #f])))
(define (alpha-filter-options-translator opt)
(let ([name (car opt)]
[val (cadr opt)])
(case name
[(enabled) (bool->string val)]
[(finish-opacity opacity finish-x finish-y start-x start-y)
(number->string val)]
[(style)
(number->string (list-pos val *alpha-filter-styles*))]
[else (error "Can't translate alpha filter option" opt)])))
(define (blend-trans-filter-options-validator opt)
(let ([name (car opt)]
[val (cadr opt)])
(case name
[(enable) #t]
[(duration) (number? val)]
[(status) (trans-filter-status? val)]
[else #f])))
(define (blend-trans-filter-options-translator opt)
(let ([name (car opt)]
[val (cadr opt)])
(case name
[(enable) (bool->string val)]
[(duration) (number->string val)]
[(status) (list-pos val *trans-filter-statuses*)]
[else (error "Can't translate blend-trans filter option" opt)])))
(define (blur-filter-options-validator opt)
(let ([name (car opt)]
[val (cadr opt)])
(case name
[(add enabled) #t]
[(direction) (filter-direction? val)]
[(strength) (exact-with-bounds? val 1 100)]
[else #f])))
(define (blur-filter-options-translator opt)
(let ([name (car opt)]
[val (cadr opt)])
(case name
[(add enabled) (bool->string val)]
[(direction strength) (number->string val)]
[else (error "Can't translate blur filter option" opt)])))
(define (chroma-filter-options-validator opt)
(let ([name (car opt)]
[val (cadr opt)])
(case name
[(enabled) #t]
[(color) (hex-color-string? val)]
[else #f])))
(define (chroma-filter-options-translator opt)
(let ([name (car opt)]
[val (cadr opt)])
(case name
[(enabled) (bool->string val)]
[(color) val]
[else (error "Can't translate chroma filter option" opt)])))
(define (drop-shadow-filter-options-validator opt)
(let ([name (car opt)]
[val (cadr opt)])
(case name
[(enabled positive) #t]
[(color) (hex-color-string? val)]
[(off-x off-y)
(and (number? val)
(exact? val))]
[else #f])))
(define (drop-shadow-filter-options-translator opt)
(let ([name (car opt)]
[val (cadr opt)])
(case name
[(enabled positive) (bool->string val)]
[(color) val]
[(off-x off-y) (number->string val)]
[else (error "Can't translate drop-shadow filter option" opt)])))
(define (basic-filter-options-validator opt)
(let ([name (car opt)]
[val (cadr opt)])
(case name
[(enabled positive) #t]
[else #f])))
(define (basic-filter-options-translator opt)
(let ([name (car opt)]
[val (cadr opt)])
(case name
[(enabled positive) (bool->string val)]
[else (error "Can't translate basic filter option" opt)])))
(define (glow-filter-options-validator opt)
(let ([name (car opt)]
[val (cadr opt)])
(case name
[(enabled) #t]
[(color) (hex-color-string? val)]
[(strength) (exact-with-bounds? val 1 100)]
[else #f])))
(define (glow-filter-options-translator opt)
(let ([name (car opt)]
[val (cadr opt)])
(case name
[(enabled) (bool->string val)]
[(color) val]
[(strength) (number->string val)]
[else (error "Can't translate glow filter option" opt)])))
(define (mask-filter-options-validator opt)
(let ([name (car opt)]
[val (cadr opt)])
(case name
[(enabled) #t]
[(color) (hex-color-string? val)]
[else #f])))
(define (mask-filter-options-translator opt)
(let ([name (car opt)]
[val (cadr opt)])
(case name
[(enabled) (bool->string val)]
[(color) val]
[else (error "Can't translate mask filter option" opt)])))
(define (reveal-trans-filter-options-validator opt)
(let ([name (car opt)]
[val (cadr opt)])
(case name
[(enabled) #t]
[(duration) (number? val)]
[(status) (trans-filter-status? val)]
[else #f])))
(define (reveal-trans-filter-options-translator opt)
(let ([name (car opt)]
[val (cadr opt)])
(case name
[(enabled) (bool->string val)]
[(duration) (number->string val)]
[(status) (list-pos val *trans-filter-statuses*)]
[else (error "Can't translate reveal-trans filter option" opt)])))
(define (shadow-filter-options-validator opt)
(let ([name (car opt)]
[val (cadr opt)])
(case name
[(enabled) #t]
[(color) (hex-color-string? val)]
[(direction) (filter-direction? val)]
[else #f])))
(define (shadow-filter-options-translator opt)
(let ([name (car opt)]
[val (cadr opt)])
(case name
[(enabled) (bool->string val)]
[(color) val]
[(direction) (number->string val)]
[else #f])))
(define (wave-filter-options-validator opt)
(let ([name (car opt)]
[val (cadr opt)])
(case name
[(enabled add) #t]
[(freq) (and (number? val)
(>= val 0))]
[(light-strength phase) (exact-with-bounds? val 0 100)]
[(strength) (exact-with-bounds? val 1 100)]
[else #f])))
(define (wave-filter-options-translator opt)
(let ([name (car opt)]
[val (cadr opt)])
(case name
[(enabled add) (bool->string val)]
[(freq) (number->string val)]
[(light-strength phase) (number->string val)]
[(strength) (number->string val)]
[else (error "Can't translate wave filter option" opt)])))
(define (filter->string filter options)
(unless (filter? filter)
(error
(format "Expected filter (element of '~a), got ~a"
*filters* filter)))
(for-each
(lambda (opt)
(unless (and (pair? opt)
(symbol? (car opt))
(eq? (length opt) 2))
(error (string-append
"Filter options must be of the form (option value), "
"got") opt)))
options)
(let* ([validators
`((alpha ,alpha-filter-options-validator
,alpha-filter-options-translator)
(blend-trans ,blend-trans-filter-options-validator
,blend-trans-filter-options-translator)
(blur ,blur-filter-options-validator
,blur-filter-options-translator)
(chroma ,chroma-filter-options-validator
,chroma-filter-options-translator)
(drop-shadow ,drop-shadow-filter-options-validator
,drop-shadow-filter-options-translator)
(flip-horizontal ,basic-filter-options-validator
,basic-filter-options-translator)
(flip-vertical ,basic-filter-options-validator
,basic-filter-options-translator)
(glow ,glow-filter-options-validator
,glow-filter-options-translator)
(gray ,basic-filter-options-validator
,basic-filter-options-translator)
(invert ,basic-filter-options-validator
,basic-filter-options-translator)
(light ,basic-filter-options-validator
,basic-filter-options-translator)
(mask ,mask-filter-options-validator
,mask-filter-options-translator)
(redirect ,basic-filter-options-validator
,basic-filter-options-translator)
(reveal-trans ,reveal-trans-filter-options-validator
,reveal-trans-filter-options-translator)
(shadow ,shadow-filter-options-validator
,shadow-filter-options-translator)
(wave ,wave-filter-options-validator
,wave-filter-options-translator)
(x-ray ,basic-filter-options-validator
,basic-filter-options-validator))]
[entry (assq filter validators)]
[validate-one (cadr entry)]
[translate-one (caddr entry)])
; validate
(for-each
(lambda (opt)
(unless (validate-one opt)
(error
(format "Invalid ~a filter option: ~a"
filter opt))))
options)
; translate
(let* ([translated-options
(map (lambda (opt)
(list
(symbol->string (car opt))
(translate-one opt)))
options)]
[flat-string-options
(let loop ([opts translated-options])
(cond
[(null? opts) ""]
[(null? (cdr opts))
(string-append
(caar opts)
"="
(cadar opts))]
[else
(string-append
(caar opts)
"="
(cadar opts)
","
(loop (cdr opts)))]))])
(string-append
(symbol->string (cadr (assq filter *filters-and-official-names*))) "("
flat-string-options
")"))))
(define (filter-opt-string->value s)
(cond
[(string=? s "true") #t]
[(string=? s "false") #f]
[(hex-digit-string? s) s]
[(string->number s) =>
(lambda (n) n)]
[else
(let ([sym (string->symbol s)])
(cond
[(alpha-filter-style? sym)
(list-pos sym *alpha-filter-styles*)]
[(trans-filter-status? sym)
(list-pos sym *trans-filter-statuses*)]
[(reveal-transition? sym)
(list-pos sym *reveal-transitions*)]
[else ; guess
s]))]))
(define (string->filter s)
; s should be of form "name(opt=val,...)"
(string-lowercase! s)
(let* ([filter-name
(regexp-match *filter-re* s)]
[filter-sym
(if filter-name
(let ([entry
(assq (string->symbol (car filter-name))
*official-names-and-filters*)])
(if entry
(cadr entry)
'empty-filter))
'empty-filter)]
[re-opt (regexp "[^,()]*=[^,()]*")]
[re-opt-name (regexp ".*=")]
[re-opt-val (regexp "=.*")])
(if (eq? filter-sym 'empty-filter)
'(empty-filter)
(let loop ([rs (regexp-replace (car filter-name) s "")]
[opts '()])
(let ([opt-match (regexp-match re-opt rs)])
(if opt-match
(let* ([one-opt (car opt-match)]
[opt-name
(let ([name
(car (regexp-match re-opt-name one-opt))])
(string->symbol
(substring name 0 (sub1 (string-length name)))))]
[opt-val
(let ([val
(car (regexp-match re-opt-val one-opt))])
(substring val 1 (string-length val)))])
(loop (regexp-replace one-opt rs "")
(cons (list opt-name
(filter-opt-string->value
opt-val)) opts)))
(cons filter-sym (reverse opts)))))))))

301
collects/mysterx/private/mxmain.rkt
View File

@ -1,301 +0,0 @@
#lang racket/base
(error "mxmain.rkt: you seem to be missing mxmain.dll; you need to build MysterX in plt\\src\\mysterx\\")
(define-syntax provide-dummy
(syntax-rules ()
[(_ id) (begin
(provide id)
(define id (false/thwart-optimization)))]
[(_ id ...) (begin (provide-dummy id) ...)]))
(define false/thwart-optimization #f)
(set! false/thwart-optimization (lambda () #f))
;; dummy entries to make Setup happy;
;; these are the names defined in mxPrims[] in src/mysterx.cxx
(provide-dummy
mx-version
block-while-browsers
com-invoke
com-set-property!
com-get-property
com-get-properties
com-set-properties
com-methods
com-events
com-method-type
com-get-property-type
com-set-property-type
com-event-type
com-help
com-object-type
com-is-a?
com-currency?
com-date?
com-date->date
date->com-date
com-scode?
com-scode->number
number->com-scode
com-currency->number
number->com-currency
com-object?
com-iunknown?
com-register-event-handler
com-unregister-event-handler
com-all-coclasses
com-all-controls
coclass->html
progid->html
cocreate-instance-from-coclass
cocreate-instance-from-progid
com-get-active-object-from-coclass
coclass
progid
set-coclass!
set-coclass-from-progid!
com-object-eq?
com-register-object
com-release-object
com-add-ref
com-ref-count
com-terminate
make-browser
browser-show
navigate
go-back
go-forward
refresh
iconize
restore
current-url
register-navigate-handler
current-document
print-document
document?
document-title
document-insert-html
document-append-html
document-replace-html
document-find-element
document-find-element-by-id-or-name
document-elements-with-tag
document-objects
element-insert-html
element-append-html
element-insert-text
element-append-text
element-replace-html
element-get-html
element-get-text
element-focus
element-selection
element-set-selection!
element-attribute
element-set-attribute!
element-click
element-tag
element-font-family
element-set-font-family!
element-font-style
element-set-font-style!
element-font-variant
element-set-font-variant!
element-font-weight
element-set-font-weight!
element-font
element-set-font!
element-background
element-set-background!
element-background-attachment
element-set-background-attachment!
element-background-image
element-set-background-image!
element-background-repeat
element-set-background-repeat!
element-background-position
element-set-background-position!
element-text-decoration
element-set-text-decoration!
element-text-transform
element-set-text-transform!
element-text-align
element-set-text-align!
element-margin
element-set-margin!
element-padding
element-set-padding!
element-border
element-set-border!
element-border-top
element-set-border-top!
element-border-bottom
element-set-border-bottom!
element-border-left
element-set-border-left!
element-border-right
element-set-border-right!
element-border-color
element-set-border-color!
element-border-width
element-set-border-width!
element-border-style
element-set-border-style!
element-border-top-style
element-set-border-top-style!
element-border-bottom-style
element-set-border-bottom-style!
element-border-left-style
element-set-border-left-style!
element-border-right-style
element-set-border-right-style!
element-style-float
element-set-style-float!
element-clear
element-set-clear!
element-display
element-set-display!
element-visibility
element-set-visibility!
element-list-style-type
element-set-list-style-type!
element-list-style-position
element-set-list-style-position!
element-list-style-image
element-set-list-style-image!
element-list-style
element-set-list-style!
element-position
element-overflow
element-set-overflow!
element-pagebreak-before
element-set-pagebreak-before!
element-pagebreak-after
element-set-pagebreak-after!
element-css-text
element-set-css-text!
element-cursor
element-set-cursor!
element-clip
element-set-clip!
element-filter
element-set-filter!
element-style-string
element-text-decoration-none
element-set-text-decoration-none!
element-text-decoration-underline
element-set-text-decoration-underline!
element-text-decoration-overline
element-set-text-decoration-overline!
element-text-decoration-linethrough
element-set-text-decoration-linethrough!
element-text-decoration-blink
element-set-text-decoration-blink!
element-pixel-top
element-set-pixel-top!
element-pixel-left
element-set-pixel-left!
element-pixel-width
element-set-pixel-width!
element-pixel-height
element-set-pixel-height!
element-pos-top
element-set-pos-top!
element-pos-left
element-set-pos-left!
element-pos-width
element-set-pos-width!
element-pos-height
element-set-pos-height!
element-font-size
element-set-font-size!
element-color
element-set-color!
element-background-color
element-set-background-color!
element-background-position-x
element-set-background-position-x!
element-background-position-y
element-set-background-position-y!
element-letter-spacing
element-set-letter-spacing!
element-vertical-align
element-set-vertical-align!
element-text-indent
element-set-text-indent!
element-line-height
element-set-line-height!
element-margin-top
element-set-margin-top!
element-margin-bottom
element-set-margin-bottom!
element-margin-left
element-set-margin-left!
element-margin-right
element-set-margin-right!
element-padding-top
element-set-padding-top!
element-padding-bottom
element-set-padding-bottom!
element-padding-left
element-set-padding-left!
element-padding-right
element-set-padding-right!
element-border-top-color
element-set-border-top-color!
element-border-bottom-color
element-set-border-bottom-color!
element-border-left-color
element-set-border-left-color!
element-border-right-color
element-set-border-right-color!
element-border-top-width
element-set-border-top-width!
element-border-bottom-width
element-set-border-bottom-width!
element-border-left-width
element-set-border-left-width!
element-border-right-width
element-set-border-right-width!
element-width
element-set-width!
element-height
element-set-height!
element-top
element-set-top!
element-left
element-set-left!
element-z-index
element-set-z-index!
event?
get-event
event-tag
event-id
event-from-tag
event-from-id
event-to-tag
event-to-id
event-keycode
event-shiftkey
event-ctrlkey
event-altkey
event-x
event-y
event-keypress?
event-keydown?
event-keyup?
event-mousedown?
event-mousemove?
event-mouseover?
event-mouseout?
event-mouseup?
event-click?
event-dblclick?
event-error?
block-until-event
process-win-events
release-type-table
com-omit
%%initialize-dotnet-runtime)

300
collects/mysterx/private/prims.rkt
View File

@ -1,300 +0,0 @@
;; prims.rkt
(module prims mzscheme
(require "mxmain.rkt")
(provide
mx-version
com-invoke
com-set-property!
com-get-property
com-methods
com-get-properties
com-set-properties
com-events
com-method-type
com-get-property-type
com-set-property-type
com-event-type
com-object-type
com-is-a?
com-date->date
date->com-date
com-date?
com-currency?
com-currency->number
number->com-currency
com-scode?
com-scode->number
number->com-scode
com-object?
com-iunknown?
com-help
com-register-event-handler
com-unregister-event-handler
com-all-coclasses
com-all-controls
coclass->html
progid->html
cocreate-instance-from-coclass
cocreate-instance-from-progid
coclass
progid
set-coclass!
set-coclass-from-progid!
com-object-eq?
com-register-object
com-release-object
com-add-ref
com-ref-count
make-browser
browser-show
navigate
go-back
go-forward
refresh
iconize
restore
register-navigate-handler
current-url
current-document
print
document?
document-title
document-insert-html
document-append-html
document-replace-html
document-find-element
document-find-element-by-id-or-name
document-elements-with-tag
document-objects
element-insert-html
element-append-html
element-replace-html
element-get-html
element-get-text
element-insert-text
element-append-text
element-focus
element-selection
element-set-selection!
element-attribute
element-set-attribute!
element-click
element-tag
element-font-family
element-set-font-family!
element-font-style
element-set-font-style!
element-font-variant
element-set-font-variant!
element-font-weight
element-set-font-weight!
element-font
element-set-font!
element-background
element-set-background!
element-background-attachment
element-set-background-attachment!
element-background-image
element-set-background-image!
element-background-repeat
element-set-background-repeat!
element-background-position
element-set-background-position!
element-text-decoration
element-set-text-decoration!
element-text-transform
element-set-text-transform!
element-text-align
element-set-text-align!
element-margin
element-set-margin!
element-padding
element-set-padding!
element-border
element-set-border!
element-border-top
element-set-border-top!
element-border-bottom
element-set-border-bottom!
element-border-left
element-set-border-left!
element-border-right
element-set-border-right!
element-border-color
element-set-border-color!
element-border-width
element-set-border-width!
element-border-style
element-set-border-style!
element-border-top-style
element-set-border-top-style!
element-border-bottom-style
element-set-border-bottom-style!
element-border-left-style
element-set-border-left-style!
element-border-right-style
element-set-border-right-style!
element-style-float
element-set-style-float!
element-clear
element-set-clear!
element-display
element-set-display!
element-visibility
element-set-visibility!
element-list-style-type
element-set-list-style-type!
element-list-style-position
element-set-list-style-position!
element-list-style-image
element-set-list-style-image!
element-list-style
element-set-list-style!
element-position
element-overflow
element-set-overflow!
element-pagebreak-before
element-set-pagebreak-before!
element-pagebreak-after
element-set-pagebreak-after!
element-css-text
element-set-css-text!
element-cursor
element-set-cursor!
element-clip
element-set-clip!
element-filter
element-set-filter!
element-style-string
element-text-decoration-none
element-set-text-decoration-none!
element-text-decoration-underline
element-set-text-decoration-underline!
element-text-decoration-overline
element-set-text-decoration-overline!
element-text-decoration-linethrough
element-set-text-decoration-linethrough!
element-text-decoration-blink
element-set-text-decoration-blink!
element-pixel-top
element-set-pixel-top!
element-pixel-left
element-set-pixel-left!
element-pixel-width
element-set-pixel-width!
element-pixel-height
element-set-pixel-height!
element-pos-top
element-set-pos-top!
element-pos-left
element-set-pos-left!
element-pos-width
element-set-pos-width!
element-pos-height
element-set-pos-height!
element-font-size
element-set-font-size!
element-color
element-set-color!
element-background-color
element-set-background-color!
element-background-position-x
element-set-background-position-x!
element-background-position-y
element-set-background-position-y!
element-letter-spacing
element-set-letter-spacing!
element-vertical-align
element-set-vertical-align!
element-text-indent
element-set-text-indent!
element-line-height
element-set-line-height!
element-margin-top
element-set-margin-top!
element-margin-bottom
element-set-margin-bottom!
element-margin-left
element-set-margin-left!
element-margin-right
element-set-margin-right!
element-padding-top
element-set-padding-top!
element-padding-bottom
element-set-padding-bottom!
element-padding-left
element-set-padding-left!
element-padding-right
element-set-padding-right!
element-border-top-color
element-set-border-top-color!
element-border-bottom-color
element-set-border-bottom-color!
element-border-left-color
element-set-border-left-color!
element-border-right-color
element-set-border-right-color!
element-border-top-width
element-set-border-top-width!
element-border-bottom-width
element-set-border-bottom-width!
element-border-left-width
element-set-border-left-width!
element-border-right-width
element-set-border-right-width!
element-width
element-set-width!
element-height
element-set-height!
element-top
element-set-top!
element-left
element-set-left!
element-z-index
element-set-z-index!
event?
get-event
event-tag
event-id
event-from-tag
event-from-id
event-to-tag
event-to-id
event-keycode
event-shiftkey
event-ctrlkey
event-altkey
event-x
event-y
event-keypress?
event-keydown?
event-keyup?
event-mousedown?
event-mousemove?
event-mouseover?
event-mouseout?
event-mouseup?
event-click?
event-dblclick?
event-error?
block-until-event
process-win-events
com-omit))

319
collects/mysterx/private/properties.rkt
View File

@ -1,319 +0,0 @@
;; properties.rkt
(module properties mzscheme
(require mzlib/list)
(provide
*css-units*
*background-attachments*
*background-repeats*
*text-transforms*
*text-aligns*
*border-widths*
*border-styles*
*displays*
*font-styles*
*font-variants*
*font-sizes*
*style-floats*
*clears*
*horizontals*
*verticals*
*decorations*
*visibilities*
*list-style-types*
*list-style-positions*
*positions*
*overflows*
*page-breaks*
*cursors*
*html-colors*
*filters-and-official-names*
*official-names-and-filters*
*filters*
*filter-official-names*
*filter-re*
*alpha-filter-styles*
*trans-filter-statuses*
*filter-directions*
*reveal-transitions*
*vertical-aligns*
decoration?
horizontal?
vertical?
font-size?
style-float?
clear?
display?
visibility?
list-style-type?
list-style-position?
position?
overflow?
pagebreak?
cursor?
filter?
alpha-filter-style?
trans-filter-status?
filter-direction?
reveal-transition?
vertical-align?
css-unit?
border-style?)
(define *css-units* '(em ex cm mm in pt pc px))
(define *background-attachments* '(fixed scroll))
(define *background-repeats* '(no-repeat repeat repeat-x repeat-y))
(define *text-transforms* '(none capitalize uppercase lowercase))
(define *text-aligns* '(left right center justify))
(define *border-widths* '(medium thin thick))
(define *border-styles* '(none dotted dashed solid double groove
ridge inset outset))
(define *displays* '(block none inline list-item
table-header-group table-footer-group))
(define *generic-font-families* '(serif sans-serif cursive
fantasy monospace))
(define *font-styles* '(normal italic oblique))
(define *font-variants* '(normal small-caps))
(define *font-sizes* '(xx-small x-small small medium large
x-large xx-large
larger smaller))
(define *style-floats* '(none left right))
(define *clears* '(none left right both))
(define *horizontals* '(left center right))
(define *verticals* '(top center bottom))
(define *decorations* '(none underline overline line-through blink))
(define *visibilities* '(inherit visible hidden))
(define *list-style-types* '(disc circle square decimal lower-roman
upper-roman lower-alpha upper-alpha none))
(define *list-style-positions* '(outside inside))
(define *positions* '(static absolute relative))
(define *overflows* '(visible scroll hidden auto))
(define *page-breaks* '(always auto none))
(define *cursors* '(auto crosshair default hand move
n-resize ne-resize nw-resize s-resize
se-resize sw-resize e-resize w-resize
text wait help))
(define *html-colors*
'(aliceblue
antiquewhite
aqua
aquamarine
azure
beige
bisque
black
blanchedalmond
blue
blueviolet
brown
burlywood
cadetblue
chartreuse
chocolate
coral
cornflower
cornsilk
crimson
cyan
darkblue
darkcyan
darkgoldenrod
darkgray
darkgreen
darkkhaki
darkmagenta
darkolivegreen
darkorange
darkorchid
darkred
darksalmon
darkseagreen
darkslateblue
darkslategray
darkturquoise
darkviolet
deeppink
deepskyblue
dimgray
dodgerblue
firebrick
floralwhite
forestgreen
fuchsia
gainsboro
ghostwhite
gold
goldenrod
gray
green
greenyellow
honeydew
hotpink
indianred
indigo
ivory
khaki
lavender
lavenderblush
lawngreen
lemonchiffon
lightblue
lightcoral
lightcyan
lightgoldenrodyellow
lightgreen
lightgray
lightpink
lightsalmon
lightseagreen
lightskyblue
lightslategray
lightsteelblue
lightyellow
lime
limegreen
linen
magenta
maroon
mediumaquamarine
mediumblue
mediumorchid
mediumpurple
mediumseagreen
mediumslateblue
mediumspringgreen
mediumturquoise
mediumvioletred
midnightblue
mintcream
mistyrose
moccasin
navajowhite
navy
oldlace
olive
olivedrab
orange
orangered
orchid
palegoldenrod
palegreen
paleturquoise
palevioletred
papayawhip
peachpuff
peru
pink
plum
powderblue
purple
red
rosybrown
royalblue
saddlebrown
salmon
sandybrown
seagreen
seashell
sienna
silver
skyblue
slateblue
slategray
snow
springgreen
steelblue
tan
teal
thistle
tomato
turquoise
violet
wheat
white
whitesmoke
yellow
yellowgreen))
(define *filters-and-official-names*
'((alpha alpha)
(blend-trans blendTrans)
(blur blur)
(chroma chroma)
(drop-shadow dropShadow)
(flip-horizontal flipH)
(flip-vertical flipV)
(glow glow)
(gray gray)
(invert invert)
(light light)
(mask mask)
(redirect redirect)
(reveal-trans revealTrans)
(shadow shadow)
(wave wave)
(x-ray xray)))
(define *official-names-and-filters*
(map (lambda (flt) (list (cadr flt)
(car flt)))
*filters-and-official-names*))
(define *filters* (map car *filters-and-official-names*))
(define *filter-official-names* (map cadr *filters-and-official-names*))
(define *filter-re*
(regexp (foldr (lambda (s t)
(if (> (string-length t) 0)
(string-append s "|" t)
s)) ""
(map symbol->string *filter-official-names*))))
(define *alpha-filter-styles*
'(uniform linear radial rectangular))
(define *trans-filter-statuses*
'(stopped applied playing))
(define *filter-directions*
'(0 45 90 135 180 225 270 315))
(define *reveal-transitions*
'(box-in box-out circle-in circle-out
wipe-up wipe-down wipe-right wipe-left
vertical-blinds horizontal-blinds checkerboard-across
checkerboard-down random-dissolve split-vertical-in
split-vertical-out split-horizontal-in split-horizontal-out
strips-left-down strips-left-up strips-right-down
strips-right-up random-bars-horizontal random-bars-vertical
random))
(define *vertical-aligns*
'(baseline sub super top middle bottom text-top text-bottom ))
; predicates based on membership in symbol lists
(define (make-sym-pred lst)
(lambda (s)
(memq s lst)))
(define decoration? (make-sym-pred *decorations*))
(define horizontal? (make-sym-pred *horizontals*))
(define vertical? (make-sym-pred *verticals*))
(define generic-font-family? (make-sym-pred *generic-font-families*))
(define font-size? (make-sym-pred *font-sizes*))
(define style-float? (make-sym-pred *style-floats*))
(define clear? (make-sym-pred *clears*))
(define display? (make-sym-pred *displays*))
(define visibility? (make-sym-pred *visibilities*))
(define list-style-type? (make-sym-pred *list-style-types*))
(define list-style-position? (make-sym-pred *list-style-positions*))
(define position? (make-sym-pred *positions*))
(define overflow? (make-sym-pred *overflows*))
(define pagebreak? (make-sym-pred *page-breaks*))
(define cursor? (make-sym-pred *cursors*))
(define filter? (make-sym-pred *filters*))
(define alpha-filter-style? (make-sym-pred *alpha-filter-styles*))
(define trans-filter-status?
(make-sym-pred *trans-filter-statuses*))
(define filter-direction? (make-sym-pred *filter-directions*))
(define reveal-transition? (make-sym-pred *reveal-transitions*))
(define vertical-align? (make-sym-pred *vertical-aligns*))
(define css-unit? (make-sym-pred *css-units*))
(define border-style? (make-sym-pred *border-styles*)))

654
collects/mysterx/private/style.rkt
View File

@ -1,654 +0,0 @@
;;; style.rkt
(module style mzscheme
(require mzlib/string)
(require "util.rkt")
(require "properties.rkt")
(provide
make-css-percentage
css-percentage?
css-percentage-num
make-css-length
css-length?
css-length-num
css-length-units
font-families->string
string->font-families
string->font-size
valid-css-length?
css-length->string
percentage-or-length?
percentage-or-length->string
make-bg-pos-getter
make-bg-pos-setter
make-element-getter
make-element-setter
make-pagebreak-getter
make-pagebreak-setter
list->background-position
border-width?
border-style->string
border-width->string
border->string
border-items->string
set-border-with-fun
string->border-item
make-border-getter
make-border-style-getter
make-border-style-setter
make-border-width-getter
make-border-width-setter
string->html-color
html-color->string
make-color-getter
make-color-setter
make-css-getter
make-css-setter
make-const-or-css-getter-maker
make-normal-or-css-getter
make-auto-or-css-getter
make-const-or-css-setter-maker
make-normal-or-css-setter
make-auto-or-css-setter
parse-string
parse-decoration
validated-string->symbols
string->list-style-item
list-style-item->string
string->background-position
string->margin
margin->string
string->padding
padding->string
url->string
string->url
clip-rect?
clip-rect->symbols)
(define-struct css-percentage (num))
(define-struct css-length (num units))
(define font-family->string
(lambda (ff)
(if (regexp-match ".* .*" ff) ; contains a space
(string-append "\"" ff "\"")
ff)))
(define font-families->string
(lambda (ffs)
(let loop ([ffs ffs])
(cond
[(null? ffs)
""]
[(null? (cdr ffs))
(font-family->string (car ffs))]
[else
(string-append (font-family->string (car ffs))
","
(loop (cdr ffs)))]))))
(define string->font-families
(lambda (s)
(let ([lst (string->list s)]
[build-curr
(lambda (cs)
(list->string (reverse (remove-ws cs))))])
(let loop ([lst lst]
[curr '()])
(cond
[(null? lst)
(if (null? curr)
'()
(list (build-curr curr)))]
[(char-ci=? #\, (car lst))
; strip leading whitespace
; start on new current word
(let ([tail (loop (remove-ws (cdr lst)) '())])
(if (null? curr)
tail
(cons (build-curr curr) tail)))]
[(member (car lst) '(#\" #\')) ; strip quotes
(loop (cdr lst) curr)]
[else
(loop (cdr lst) (cons (car lst) curr))])))))
(define (string->font-size s)
(let ([sym (string->symbol s)])
(cond
[(font-size? sym) sym]
[(parse-css-length (string->list s)) =>
(lambda (val-rest) (car val-rest))]
[else s])))
(define (valid-css-length? elt)
(and (css-length? elt)
(exact? (css-length-num elt))
(css-unit? (css-length-units elt))))
(define (css-length->string elt)
(string-append (number->string (css-length-num elt))
(symbol->string (css-length-units elt))))
(define percentage-or-length?
(lambda (elt)
(or (and (css-percentage? elt)
(exact? (css-percentage-num elt)))
(and (valid-css-length? elt)))))
(define percentage-or-length->string
(lambda (elt)
(cond
[(css-length? elt)
(css-length->string elt)]
[(css-percentage? elt)
(string-append (number->string (css-percentage-num elt)) "%")]
[else
(error "Not a CSS percentage or length: ~a" elt)])))
(define (make-bg-pos-getter elt f fname)
(lambda ()
(let ([pos (f elt)])
(when (empty-string? pos)
(empty-property-error fname))
(car (list->background-position (string->list pos))))))
(define (make-bg-pos-setter elt f pred? elts coord)
(lambda (pos)
(cond
[(pred? pos)
(f elt (symbol->string pos))]
[(percentage-or-length? pos)
(f elt (percentage-or-length->string pos))]
[else
(error
(format
(string-append
"set-background-position-~a!: "
"Expected value in ~a, "
"CSS length, or CSS percentage, "
"got ~a")
coord elts pos))])))
(define (make-element-getter elt getter name)
(lambda ()
(let ([s (getter elt)])
(if (empty-string? s)
(empty-property-error name)
(string->symbol s)))))
(define (make-element-setter elt pred? props f!)
(lambda (s)
(unless (pred? s)
(error
(format "Expected element of ~a, got: ~a"
props s)))
(f! elt (symbol->string s))))
(define (make-pagebreak-getter elt f)
(lambda ()
(let ([s (f elt)])
(if (empty-string? s)
'none
(string->symbol s)))))
(define (make-pagebreak-setter elt f! name)
(lambda (s)
(unless (pagebreak? s)
(error
(format "~a: Expected element of ~a, got: ~a"
name *page-breaks* s)))
(let ([str (if (eq? s 'none)
""
(symbol->string s))])
(f! elt str))))
(define (border-width? elt)
(or (memq elt *border-widths*)
(valid-css-length? elt)))
(define border-style->string symbol->string)
(define (border-width->string elt)
(if (css-length? elt)
(css-length->string elt)
(symbol->string elt)))
(define (border->string elt)
(cond
[(border-width? elt)
(border-width->string elt)]
[(border-style? elt)
(border-style->string elt)]
[(html-color? elt)
(html-color->string elt)]))
(define (border-items->string elts)
(fold-strings-with-spaces (map border->string elts)))
(define (set-border-with-fun elt cs f)
(for-each
(lambda (c)
(unless (or (border-width? c)
(border-style? c)
(html-color? c))
(error
(format
(string-append
"set-border!: expected nonempty list where each "
"element is either "
"a border width (one of '~a, or a CSS length), "
"a border style (one of '~a, or "
"an HTML color, got ~a")
*border-widths*
*border-styles*
c))))
cs)
(f elt (border-items->string cs)))
(define (string->border-item s)
(let ([sym (string->symbol s)])
(cond
;color
[(memq sym *html-colors*)
sym]
[(hex-digit-string? s)
s]
;style
[(memq sym *border-styles*)
sym]
;width
[(memq sym *border-widths*)
sym]
[(parse-css-length (string->list s)) => car]
;error
[else
(error (format "Expected border item, got: ~a" s))])))
(define (string->border-list s)
(map string->border-item (parse-string s)))
(define (make-border-getter elt f name)
(lambda ()
(let ([s (f elt)])
(if (empty-string? s)
(empty-property-error name)
(string->border-list s)))))
(define (make-border-style-getter elt f name)
(lambda ()
(let ([s (f elt)])
(if (empty-string? s)
(empty-property-error name)
(string->border-item s)))))
(define (make-border-style-setter elt f name)
(lambda (s)
(unless (border-style? s)
(error
(format "~a: Expected element of ~a, got ~a"
name *border-styles* s)))
(f elt (border-style->string s))))
(define (make-border-width-getter elt f name)
(lambda ()
(let ([s (f elt)])
(if (empty-string? s)
(empty-property-error name)
(string->border-item s)))))
(define (make-border-width-setter elt f name)
(lambda (s)
(unless (border-width? s)
(error
(format "~a: Expected element of ~a or CSS length, got ~a"
name *border-widths* s)))
(f elt (border->string s))))
(define (string->html-color s)
(if (char=? (string-ref s 0) #\#)
s
(string->symbol s)))
(define (html-color->string s)
(if (symbol? s)
(symbol->string s)
s))
(define (make-color-getter elt f name)
(lambda ()
(let ([s (f elt)])
(if (empty-string? s)
(empty-property-error name)
(string->html-color s)))))
(define (make-color-setter elt f name)
(lambda (s)
(unless
(html-color? s)
(error
(format "~a: Expected HTML color, got: ~a"
name s)))
(f elt (html-color->string s))))
(define (make-css-getter elt f fname)
(lambda ()
(let ([s (f elt)])
(when (empty-string? s)
(empty-property-error fname))
(cond
[(parse-css-length (string->list s)) => car]
[else s]))))
(define (make-css-setter elt f fname)
(lambda (css)
(let ([s (cond
[(percentage-or-length? css)
(percentage-or-length->string css)]
[else
(error
(string-append
fname ": Expected "
"CSS length or percentage, got")
css)])])
(f elt s))))
(define (make-const-or-css-getter-maker c)
(lambda (elt f fname)
(lambda ()
(let ([s (f elt)])
(when (empty-string? s)
(empty-property-error fname))
(cond
[(string=? (symbol->string c) s) c]
[(parse-css-length (string->list s)) => car]
[else s])))))
(define make-normal-or-css-getter
(make-const-or-css-getter-maker 'normal))
(define make-auto-or-css-getter
(make-const-or-css-getter-maker 'auto))
(define (make-const-or-css-setter-maker c)
(lambda (elt f fname)
(lambda (v)
(let ([s (cond
[(eq? v c) (symbol->string c)]
[(percentage-or-length? v)
(percentage-or-length->string v)]
[else
(error
(string-append
fname ": Expected 'normal, "
"CSS length or percentage, got")
v)])])
(f elt s)))))
(define make-normal-or-css-setter
(make-const-or-css-setter-maker 'normal))
(define make-auto-or-css-setter
(make-const-or-css-setter-maker 'auto))
(define (html-color? s)
(or (hex-color-string? s)
(memq s *html-colors*)))
(define parse-number ; returns number, rest of list
(lambda (lst)
(let loop ([num? #f]
[seen-dot #f]
[digits '()]
[lst lst])
(let ([c (car lst)])
(cond
[(char-numeric? c)
(loop #t seen-dot (cons c digits) (cdr lst))]
[(eq? c #\.)
(if seen-dot
(error "More than one period in number")
(loop #t #t (cons c digits) (cdr lst)))]
[else
(if num?
(cons (string->number
(list->string (reverse digits))) lst)
#f)])))))
; (listof char) -> (cons symbol (listof char))
(define parse-units ; returns unit symbol, rest of list
(lambda (lst)
(let* ([sym-rest
(let loop ([word '()]
[lst lst])
(cond
[(or (null? lst) (char-whitespace? (car lst)))
(cons (string->symbol (list->string (reverse word)))
lst)]
[else
(loop (cons (car lst) word) (cdr lst))]))]
[sym (car sym-rest)]
[rst (cdr sym-rest)])
(if (or (eq? sym '%) (css-unit? sym))
(cons sym rst)
(error "Unable to parse units")))))
; (listof symbols) -> (listof char) -> (union #f (listof symbol))
(define make-words-parser
(lambda (syms)
(lambda (lst)
(let loop ([word '()]
[lst lst])
(cond
[(or (null? lst)
(char-whitespace? (car lst)))
(let ([sym (string->symbol (list->string (reverse word)))])
(if (memq sym syms)
(cons sym lst)
#f))]
[else
(loop (cons (car lst) word) (cdr lst))])))))
(define parse-horizontal
(make-words-parser *horizontals*))
(define parse-vertical
(make-words-parser *verticals*))
(define parse-string ; string -> (listof string)
(lambda (s)
(let ([tack-on-word
(lambda (word words)
(if (null? word)
words
(cons (list->string (reverse word)) words)))])
(let loop ([word '()]
[words '()]
[lst (string->list s)])
(cond
[(null? lst)
(reverse (tack-on-word word words))]
[(char-whitespace? (car lst))
(loop '() (tack-on-word word words) (cdr lst))]
[else
(loop (cons (car lst) word) words (cdr lst))])))))
(define (parse-css-length lst)
(cond
[(parse-number lst) =>
(lambda (num-rest)
(let ([num (car num-rest)]
[rst (cdr num-rest)])
(cond
[(parse-units rst) =>
(lambda (unit-rest)
(let* ([units (car unit-rest)]
[val (if (eq? units '%)
(make-css-percentage num)
(make-css-length num units))])
(cons val (cdr unit-rest))))]
[else #f])))]
[else #f]))
(define parse-decoration
(make-words-parser *decorations*))
(define validated-string->symbols
(lambda (s funname parser)
(if (empty-string? s)
(empty-property-error funname)
(let ([lst (string->list s)])
(let loop ([lst lst]
[words '()])
(let ([word-rest (parser lst)])
(if word-rest
(loop (remove-ws (cdr word-rest))
(cons (car word-rest) words))
(reverse words))))))))
(define (string->list-style-item s)
(if (string-ci=? (substring s 0 4) "url(")
(url->string s)
(let ([sym (string->symbol s)])
(if (or (list-style-type? sym)
(list-style-position? sym))
sym
(error (format "Expected list-style item, got: ~a"
s))))))
(define (list-style-item->string s)
(cond
[(or (list-style-type? s)
(list-style-position? s))
(symbol->string s)]
[(string? s)
(string->url s)]
[else
(error
(format "Expected list-style item, got: ~a"))]))
(define string->background-position
(lambda (s)
(let ([bp (list->background-position (string->list s))])
(case (length bp)
[(1) (car bp)]
[(2) bp]
[else "Invalid background position"]))))
(define list->background-position
(lambda (lst)
(cond
[(null? lst) '()]
[(parse-css-length lst) =>
(lambda (val-rest)
(cons (car val-rest)
(list->background-position
(remove-ws (cdr val-rest)))))]
[(parse-horizontal lst) =>
(lambda (x-rest)
(cons (car x-rest)
(list->background-position (remove-ws (cdr x-rest)))))]
[(parse-vertical lst) =>
(lambda (y-rest)
(cons (car y-rest)
(list->background-position (remove-ws (cdr y-rest)))))]
[else
(error "Can't parse background-position")])))
(define (make-css-parser loop lst)
(lambda (num-rest)
(let ([num (car num-rest)]
[rst (cdr num-rest)])
(let* ([unit-rest (parse-units rst)]
[units (car unit-rest)]
[the-val (if (eq? units '%)
(make-css-percentage num)
(make-css-length num units))])
(cons the-val (loop (cdr lst)))))))
(define string->margin
(lambda (s)
(let loop ([lst (parse-string s)])
(when (> (length lst) 4)
(error "Only four margin values allowed, got" s))
(cond
[(null? lst)
'()]
[(string=? (car lst) "auto")
(cons 'auto (loop (cdr lst)))]
[(parse-number (string->list (car lst))) =>
(make-css-parser loop lst)]
[else
(error (string-append
"Expected margin string with up to four of "
"CSS length, CSS percentage, or auto. Got")
s)]))))
(define string->padding
(lambda (s)
(let loop ([lst (parse-string s)])
(when (> (length lst) 4)
(error "Only four padding values allowed, got" s))
(cond
[(null? lst)
'()]
[(parse-number (string->list (car lst))) =>
(make-css-parser loop lst)]
[else
(error (string-append
"Expected padding string with up to four of "
"CSS lengths or CSS percentages. Got")
s)]))))
(define string->percentage-or-length
(lambda (s)
(let ([lst (string->list s)])
(cond
[(parse-number (string->list (car lst))) =>
(lambda (num-rest)
(let ([num (car num-rest)]
[rst (cdr num-rest)])
(let* ([unit-rest (parse-units rst)]
[units (car unit-rest)]
[the-val (if (eq? units '%)
(make-css-percentage num)
(make-css-length num units))])
the-val)))]
[else
(error "Expected string with percentage or length, got ~a"
s)]))))
(define margin-item->string
(lambda (item)
(cond
[(eq? item 'auto)
"auto"]
[else
(percentage-or-length->string item)])))
(define margin->string
(map-to-string margin-item->string))
(define padding->string
(map-to-string percentage-or-length->string))
(define (url->string s)
; "url(foo)" -> "foo"
(substring s 4 (sub1 (string-length s))))
(define (string->url s)
; ""foo" -> url(foo)"
(string-append "url(" s ")"))
(define (clip-rect? s)
(string-ci=?
(substring s 0 5) "rect("))
(define (clip-rect->symbols s)
(map (lambda (s)
(if (string=? s "auto")
'auto
(car (parse-css-length (string->list s)))))
(parse-string (substring s 5 (sub1 (string-length s)))))))

34
collects/mysterx/private/util.rkt
View File

@ -1,34 +0,0 @@
;;; util.rkt -- utility procedures for MysterX
#lang scheme/base
(require scheme/string)
(provide (all-defined-out))
(define (fold-strings-with-spaces strs) (string-join strs " "))
(define (map-to-string f)
(lambda (lst) (fold-strings-with-spaces (map f lst))))
(define (empty-string? s) (equal? "" s))
(define (bool->string v) (if v "true" "false"))
(define (exact-with-bounds? n lo hi) (and (exact-integer? n) (<= lo n hi)))
(define (list-pos v lst)
(for/or ([x (in-list lst)] [i (in-naturals)]) (and (eq? x v) i)))
(define (remove-ws cs) ; remove leading whitespace
(cond [(null? cs) '()]
[(char-whitespace? (car cs)) (remove-ws (cdr cs))]
[else cs]))
(define (symbols->string syms) ; '(a b c ...) => "a b c ..."
(fold-strings-with-spaces (map symbol->string syms)))
(define (hex-digit-string? elt) (regexp-match? #px"(?i:^#[0-9a-f]{6}$)" elt))
(define (hex-color-string? s) (and (string? s) (hex-digit-string? s)))
(define (empty-property-error p)
(error (format "Empty value for property ~a" p)))

15
collects/mysterx/scribblings/methprop.scrbl
View File

@ -34,7 +34,8 @@
The optional argument @racket[where] indicates a for running the
instance, and may be @racket['local], @racket['remote], or a string
indicating a machine name. See @secref["remote"] for more
indicating a machine name. See @secref[#:doc '(lib
"scribblings/foreign/foreign.scrbl") "remote"] for more
information.}
@deftogether[(
@ -164,15 +165,3 @@ Like @racket[cocreate-instance-from-coclass], but using a ProgID.}
Returns @racket[#t] if the argument is a COM object, @racket[#f]
otherwise.}
@defproc[(com-add-ref [obj com-object?]) void?]{
Increments the reference count for @racket[obj].
This procedure should only be called when system-level
errors occur due to a mismanaged COM object. Ordinarily,
MysterX handles all COM reference-counting automatically.}
@defproc[(com-ref-count [obj com-object?]) exact-nonnegative-integer?]{
Returns a number indicating the current reference count
for a COM object.}

23
collects/mysterx/scribblings/mysterx.scrbl
View File

@ -1,26 +1,27 @@
#lang scribble/doc
@(require "common.rkt")
@title{MysterX: Using Windows COM Objects in Racket}
@title{MysterX: Legacy Support for Windows COM}
@author["Paul Steckler"]
@bold{MysterX} is a toolkit for building Windows applications from
@as-index{ActiveX} and COM components, using Racket as glue code.
Dynamic HTML (DHTML) is used for component presentation and
event-handling.
@bold{MysterX} allows scripting of most COM components from Racket. A COM
component can be scripted in MysterX if it supports OLE Automation via
the @tt{IDispatch} interface, and if it publishes type information
using the @tt{ITypeInfo} interface.
@yellow{@bold{WARNING:}} All ActiveX support (as described in
@secref["activex"]) is scheduled for removal from MysterX after
version 5.2.1.
@yellow{@bold{NOTE:}} MysterX is supported but depracated; use
@racketmodname[ffi/com] or @racketmodname[ffi/unsafe/com], instead.
MysterX formerly provided @as-index{ActiveX}
support, but ActiveX support has been discontinued.
@defmodule[mysterx]
@table-of-contents[]
@include-section["overview.scrbl"]
@include-section["com.scrbl"]
@include-section["activex.scrbl"]
@include-section["methprop.scrbl"]
@include-section["com-types.scrbl"]
@include-section["com-events.scrbl"]
@include-section["version.scrbl"]
@index-section[]

33
collects/tests/mysterx/README
View File

@ -1,33 +0,0 @@
MysterX test control
====================
The file mystests.ss in this directory creates a window
with a test ActiveX control, and runs a number of tests on it.
After the internal tests are performed, you can interact
with the test control using a mouse.
The C++ code in the src subdirectory is supplied uncompiled.
You need Visual C++ .NET to compile it.
To compile, run "nmake". Once you've compiled the test ActiveX
control, load "mystests.ss".
DHTML test code
===============
The file dhtmltests.ss contains a number of tests
for the Dynamic HTML capabilities of MysterX.
Simply load the file into Racket or DrRacket to run the
tests. Any errors will be printed in the REPL.
The behavior that appears in the window that is created
may be ignored.
Manual tests
============
Here are some manual tests to run on MysterX:
- run mxdemo.ss (in the collection) under IE4, IE5, IE5.5
- check for no context menu in browsers
- load mxdemo.ss into DrRacket; hit Run a second time,
the browser windows should disappear

161
collects/tests/mysterx/dhtmltests.rktl
View File

@ -1,161 +0,0 @@
;;; dhtmltests.rkt -- DHTML tests for MysterX
(require mzlib/class)
; set inspector so structures can be compared
(define insp (current-inspector))
(current-inspector (make-inspector))
(require mysterx)
(current-inspector insp)
(define wb
(instantiate mx-browser% ()
(label "DHTML tests")
(width 300)
(height 300)
(style-options '(maximize))))
(define doc (send wb current-document))
(send doc insert-html "<P id=\"text\">This is some text</P>")
(define txt (send doc find-element "P" "text"))
(define (test-prop getter setter expected)
(printf "Checking ~a\n" getter)
(send-generic txt (make-generic mx-element% setter) expected)
(let ([got (send-generic txt (make-generic mx-element% getter))])
(unless (equal? got expected)
(printf "~a: Expected ~a, got ~a\n"
getter expected got))))
(define tests
`((font-family set-font-family! ("monospace" "fantasy"))
(font-size set-font-size! xx-large)
(font-style set-font-style! oblique)
(font-variant set-font-variant! small-caps)
(font-weight set-font-weight! bolder)
(background-attachment set-background-attachment! fixed)
(background-image
set-background-image!
"http://www.cs.rice.edu/CS/PLT/packages/drscheme/logo.gif")
(background-repeat set-background-repeat! no-repeat)
(background-position set-background-position! (right bottom))
(background-position-x set-background-position-x!
,(make-css-length 42 'em))
(background-position-y set-background-position-y!
,(make-css-percentage 95))
(letter-spacing set-letter-spacing! normal)
(letter-spacing set-letter-spacing!
,(make-css-length 20 'pt))
(vertical-align set-vertical-align! super)
(text-decoration set-text-decoration! (underline line-through))
(text-decoration-underline set-text-decoration-underline! #t)
(text-decoration-overline set-text-decoration-overline! #t)
(text-decoration-linethrough set-text-decoration-linethrough! #t)
(text-decoration-blink set-text-decoration-blink! #t)
(color set-color! red)
(background-color set-background-color! orange)
(pixel-top set-pixel-top! 27)
(pixel-left set-pixel-left! 99)
(pixel-width set-pixel-width! 99)
(pixel-height set-pixel-height! 199)
(overflow set-overflow! scroll)
(pos-top set-pos-top! 13.0)
(pos-left set-pos-left! 17.0)
(pos-width set-pos-width! 188.0)
(text-transform set-text-transform! uppercase)
(text-align set-text-align! justify)
(text-indent set-text-indent! ,(make-css-length 50 'pt))
(line-height set-line-height! ,(make-css-percentage 200))
(margin set-margin! (auto ,(make-css-length 70 'pt) auto auto))
(margin-top set-margin-top! ,(make-css-length 70 'pt))
(margin-bottom set-margin-bottom! auto)
(margin-left set-margin-left! auto)
(margin-right set-margin-right! ,(make-css-percentage 200))
(pagebreak-before set-pagebreak-before! always)
(pagebreak-after set-pagebreak-after! always)
(cursor set-cursor! help)
(padding set-padding! ,(list (make-css-length 70 'pt) (make-css-percentage 300)))
(padding-top set-padding-top! ,(make-css-length 30 'em))
(padding-bottom set-padding-bottom! ,(make-css-length 3 'cm))
(padding-left set-padding-left! ,(make-css-length 3 'ex))
(padding-right set-padding-right! ,(make-css-length 70 'mm))
(border set-border! (blue ,(make-css-length 6 'pt) solid))
(border-top set-border-top! (red ,(make-css-length 8 'pt) dashed))
(border-bottom set-border-bottom! (green ,(make-css-length 4 'pt) dotted))
(border-left set-border-left! (pink thick dotted))
(border-right set-border-right! (black thin dashed))
(border-color set-border-color! orange)
(border-top-color set-border-top-color! cyan)
(border-bottom-color set-border-bottom-color! darkseagreen)
(border-left-color set-border-left-color! goldenrod)
(border-right-color set-border-right-color! purple)
(border-width set-border-width! ,(make-css-length 20 'pt))
(border-top-width set-border-top-width! ,(make-css-length 15 'pt))
(border-bottom-width set-border-bottom-width! ,(make-css-length 15 'pt))
(border-left-width set-border-left-width! ,(make-css-length 15 'pt))
(border-right-width set-border-right-width! ,(make-css-length 15 'pt))
(border-bottom-width set-border-bottom-width! ,(make-css-length 30 'pt))
(border-left-width set-border-left-width! ,(make-css-length 30 'em))
(border-right-width set-border-right-width! ,(make-css-length 1 'in))
(border-style set-border-style! solid)
(border-top-style set-border-top-style! none)
(border-bottom-style set-border-bottom-style! dashed)
(border-left-style set-border-left-style! dotted)
(border-right-style set-border-right-style! none)
(style-float set-style-float! left)
(display set-display! list-item)
(list-style-type set-list-style-type! lower-roman)
(list-style-position set-list-style-position! inside)
(visibility set-visibility! hidden)
(clip set-clip!
(,(make-css-length 2 'cm) auto
,(make-css-length 5 'in) auto))
(clip set-clip!
(,(make-css-length 2 'cm) auto
,(make-css-length 5 'in) auto))
(style-float set-style-float! left)
(clear set-clear! both)
(width set-width! ,(make-css-percentage 50))
(height set-height! ,(make-css-percentage 50))
(top set-top! auto)
(left set-left! auto)
(z-index set-z-index! 4)))
(for-each
(lambda (t)
(apply test-prop t))
tests)
; filter test
(define flt 'glow)
(define opt1 '(strength 99))
(define opt2 '(enabled #t))
(define opt3 '(color "#ff00ff"))
(define filter-spec (list flt opt1 opt2 opt3))
(send-generic txt (make-generic mx-element% 'set-filter!)
flt opt1 opt2 opt3)
(let ([result (send txt filter)])
(if (equal? result filter-spec)
(printf "Checking filter\n")
(error (format "filter test: Expected ~a, got ~a\n"
filter-spec result))))
(printf "Navigating to CNN\n")
(send wb navigate "http://www.cnn.com")
(sleep 2)
(printf "Navigating to IBM\n")
(send wb navigate/status "http://www.ibm.com")
(sleep 2)
(printf "Back to CNN\n")
(send wb go-back)
(sleep 2)
(printf "Forward to IBM\n")
(send wb go-forward)

115
collects/tests/mysterx/mystests.rktl
View File

@ -1,115 +0,0 @@
;;; mystests.rkt -- test suite for MysterX
(require mzlib/class mysterx)
(define errors? #f)
(define wb
(instantiate mx-browser% () (label "MysTest") (width 230) (height 250)))
(define doc (send wb current-document))
(define ctrl (send doc insert-object-from-coclass "TestControl Class" 95 95 'percent))
(define (inv f . args) (apply com-invoke ctrl f args))
(define (test-currency n)
(= n (com-currency->number (number->com-currency n))))
(define (test-scode n)
(= n (com-scode->number (number->com-scode n))))
(define (test-date date)
(equal? date (com-date->date (date->com-date date))))
(for-each
(lambda (n)
(unless (test-scode n)
(printf "Error in test-scode for value ~a\n" n)
(set! errors? #t)))
'(25 -22 -1 -233344433 177000000 859489222))
(define (test-numprop ndx retval)
(com-set-property! ctrl (list "Numprop" ndx) 55)
(unless (= (com-get-property ctrl (list "Numprop" ndx)) retval)
(printf "Error in setting Numprop")
(set! errors? #t)))
(test-numprop 26 42)
(test-numprop 10 99)
(print-struct #t)
(let ([date (seconds->date (current-seconds))])
(set-date-dst?! date #f)
(set-date-time-zone-offset! date 0)
(unless (test-date date)
(printf "Error in test-date\n")
(set! errors? #t)))
(for-each
(lambda (n)
(unless (test-currency n)
(printf "Error in test-currency for value ~a\n" n)
(set! errors? #t)))
'(0 1 3.14 25.00 -22.34 11.7832 91000000000 25034343434.9933))
(define com-tests
`(("AddTest" (39 ,(box 420)) ,(+ 39 420))
("AddTest" (420 ,(box 39)) ,(+ 420 39))
("FloatTest" (4.7 5.2) ,(- 5.2 4.7))
("FloatTest" (88.7 33.2) ,(- 33.2 88.7))
("FloatTest" (-88.7 33.2) ,(- 33.2 -88.7))
("UnsignedTest" (92 97) ,(- 97 92))
("UnsignedTest" (20 33) ,(- 33 20))
("UnsignedTest" (1 12) ,(- 12 1))
("StringTest" ("abc" "def") ,"abcdef")
("StringTest" ("Supercali" "fragilistic") ,"Supercalifragilistic")
("ShortTest" (42 17) ,(* 42 17))
("ShortTest" (77 -22) ,(* 77 -22))))
(for-each
(lambda (t)
(let ([got (apply inv (car t) (cadr t))]
[expected (caddr t)])
(unless (equal? got expected)
(set! errors? #t)
(printf "Error in com-tests. Expected: ~a\nGot : ~a\n"
expected got))))
com-tests)
(define caption "SomeCaption")
(com-set-property! ctrl "Caption" caption)
(unless (string=? caption (com-get-property ctrl "Caption"))
(set! errors? #t))
(if errors?
(printf "There were errors!\n")
(printf "No errors in conversions and COM tests\n"))
(define (make-mousefun s)
(let ([t (string-append s ": button = ~a shift = ~a x = ~a y = ~a\n")])
(lambda (button shift x y)
(printf t button shift x y))))
(define (mouse-pair s)
(list s (make-mousefun s)))
(unless errors?
(for-each
(lambda (sf)
(com-register-event-handler ctrl (car sf) (cadr sf)))
`(("Click"
,(lambda () (printf "Click\n")))
,(mouse-pair "MouseMove")
,(mouse-pair "MouseDown")
,(mouse-pair "MouseUp")))
(printf "Try clicking and moving the mouse over the object\n")
(printf "You should see Click, MouseMove, MouseDown, and MouseUp events\n"))

2
collects/tests/mysterx/src/Makefile
View File

@ -1,2 +0,0 @@
all :
nmake /f testobject.mak

18
collects/tests/mysterx/src/resource.h
View File

@ -1,18 +0,0 @@
//{{NO_DEPENDENCIES}}
// Microsoft Developer Studio generated include file.
// Used by testobject.rc
//
#define IDS_PROJNAME 100
#define IDB_TESTCONTROL 101
#define IDR_TESTCONTROL 102
// Next default values for new objects
//
#ifdef APSTUDIO_INVOKED
#ifndef APSTUDIO_READONLY_SYMBOLS
#define _APS_NEXT_RESOURCE_VALUE 201
#define _APS_NEXT_COMMAND_VALUE 32768
#define _APS_NEXT_CONTROL_VALUE 201
#define _APS_NEXT_SYMED_VALUE 103
#endif
#endif

12
collects/tests/mysterx/src/stdafx.cxx
View File

@ -1,12 +0,0 @@
// stdafx.cpp : source file that includes just the standard includes
// stdafx.pch will be the pre-compiled header
// stdafx.obj will contain the pre-compiled type information
#include "stdafx.h"
#ifdef _ATL_STATIC_REGISTRY
#include <statreg.h>
#include <statreg.cpp>
#endif
#include <atlimpl.cpp>

28
collects/tests/mysterx/src/stdafx.h
View File

@ -1,28 +0,0 @@
// stdafx.h : include file for standard system include files,
// or project specific include files that are used frequently,
// but are changed infrequently
#if !defined(AFX_STDAFX_H__07B31FF3_19EE_11D3_B5DB_0060089002FE__INCLUDED_)
#define AFX_STDAFX_H__07B31FF3_19EE_11D3_B5DB_0060089002FE__INCLUDED_
#if _MSC_VER > 1000
#pragma once
#endif // _MSC_VER > 1000
#define STRICT
#ifndef _WIN32_WINNT
#define _WIN32_WINNT 0x0400
#endif
#define _ATL_APARTMENT_THREADED
#include <atlbase.h>
//You may derive a class from CComModule and use it if you want to override
//something, but do not change the name of _Module
extern CComModule _Module;
#include <atlcom.h>
#include <atlctl.h>
//{{AFX_INSERT_LOCATION}}
// Microsoft Visual C++ will insert additional declarations immediately before the previous line.
#endif // !defined(AFX_STDAFX_H__07B31FF3_19EE_11D3_B5DB_0060089002FE__INCLUDED)

BIN
collects/tests/mysterx/src/testcont.bmp
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 246 B

61
collects/tests/mysterx/src/testcontrol.cxx
View File

@ -1,61 +0,0 @@
// TestControl.cpp : Implementation of CTestControl
#include "stdafx.h"
#include "Testobject.h"
#include "TestControl.h"
/////////////////////////////////////////////////////////////////////////////
// CTestControl
STDMETHODIMP CTestControl::AddTest(long n1, long *n2, long *n3)
{
// note side effect
*n3 = n1 + *n2;
*n2 = n1;
return S_OK;
}
STDMETHODIMP CTestControl::StringTest (BSTR s1, BSTR s2, BSTR *s3)
{
int len1,len2;
len1 = SysStringLen(s1);
len2 = SysStringLen(s2);
*s3 = SysAllocStringByteLen (NULL, (len1 + len2)*2);
wcsncpy (*s3, s1, len1);
wcsncpy (*s3 + len1, s2, len2);
return S_OK;
}
STDMETHODIMP CTestControl::ShortTest (short n1, short n2, short *n3)
{
*n3 = n1 * n2;
return S_OK;
}
STDMETHODIMP CTestControl::FloatTest (double n1, double n2, double *n3)
{
*n3 = n2 - n1;
return S_OK;
}
STDMETHODIMP CTestControl::UnsignedTest (unsigned n1, unsigned n2, unsigned *n3)
{
*n3 = n2 - n1;
return S_OK;
}
STDMETHODIMP CTestControl::get_Numprop (long ndx,long *pVal)
{
*pVal = the_value;
return S_OK;
}
STDMETHODIMP CTestControl::put_Numprop (long ndx,long newVal)
{
the_value = (ndx > 21) ? 42 : 99;
return S_OK;
}

186
collects/tests/mysterx/src/testcontrol.h
View File

@ -1,186 +0,0 @@
// TestControl.h : Declaration of the CTestControl
#ifndef __TESTCONTROL_H_
#define __TESTCONTROL_H_
#include "resource.h" // main symbols
#include <windowsx.h>
#include <atlctl.h>
#include "testobjectCP.h"
/////////////////////////////////////////////////////////////////////////////
// CTestControl
class ATL_NO_VTABLE CTestControl :
public CComObjectRootEx<CComSingleThreadModel>,
public CStockPropImpl<CTestControl, ITestControl, &IID_ITestControl, &LIBID_TESTOBJECTLib>,
public CComControl<CTestControl>,
public IPersistStreamInitImpl<CTestControl>,
public IOleControlImpl<CTestControl>,
public IOleObjectImpl<CTestControl>,
public IOleInPlaceActiveObjectImpl<CTestControl>,
public IViewObjectExImpl<CTestControl>,
public IOleInPlaceObjectWindowlessImpl<CTestControl>,
public IConnectionPointContainerImpl<CTestControl>,
public IPersistStorageImpl<CTestControl>,
public ISpecifyPropertyPagesImpl<CTestControl>,
public IQuickActivateImpl<CTestControl>,
public IDataObjectImpl<CTestControl>,
public IProvideClassInfo2Impl<&CLSID_TestControl, &DIID__ITestControlEvents, &LIBID_TESTOBJECTLib>,
public IPropertyNotifySinkCP<CTestControl>,
public CComCoClass<CTestControl, &CLSID_TestControl>,
public CProxy_ITestControlEvents< CTestControl >
{
private:
long the_value;
public:
CTestControl()
{
the_value = 0L;
}
DECLARE_REGISTRY_RESOURCEID(IDR_TESTCONTROL)
DECLARE_PROTECT_FINAL_CONSTRUCT()
BEGIN_COM_MAP(CTestControl)
COM_INTERFACE_ENTRY(ITestControl)
COM_INTERFACE_ENTRY(IDispatch)
COM_INTERFACE_ENTRY(IViewObjectEx)
COM_INTERFACE_ENTRY(IViewObject2)
COM_INTERFACE_ENTRY(IViewObject)
COM_INTERFACE_ENTRY(IOleInPlaceObjectWindowless)
COM_INTERFACE_ENTRY(IOleInPlaceObject)
COM_INTERFACE_ENTRY2(IOleWindow, IOleInPlaceObjectWindowless)
COM_INTERFACE_ENTRY(IOleInPlaceActiveObject)
COM_INTERFACE_ENTRY(IOleControl)
COM_INTERFACE_ENTRY(IOleObject)
COM_INTERFACE_ENTRY(IPersistStreamInit)
COM_INTERFACE_ENTRY2(IPersist, IPersistStreamInit)
COM_INTERFACE_ENTRY(IConnectionPointContainer)
COM_INTERFACE_ENTRY(ISpecifyPropertyPages)
COM_INTERFACE_ENTRY(IQuickActivate)
COM_INTERFACE_ENTRY(IPersistStorage)
COM_INTERFACE_ENTRY(IDataObject)
COM_INTERFACE_ENTRY(IProvideClassInfo)
COM_INTERFACE_ENTRY(IProvideClassInfo2)
COM_INTERFACE_ENTRY_IMPL(IConnectionPointContainer)
END_COM_MAP()
BEGIN_PROP_MAP(CTestControl)
PROP_DATA_ENTRY("_cx", m_sizeExtent.cx, VT_UI4)
PROP_DATA_ENTRY("_cy", m_sizeExtent.cy, VT_UI4)
PROP_ENTRY("Caption", DISPID_CAPTION, CLSID_NULL)
// Example entries
// PROP_ENTRY("Property Description", dispid, clsid)
// PROP_PAGE(CLSID_StockColorPage)
END_PROP_MAP()
BEGIN_CONNECTION_POINT_MAP(CTestControl)
CONNECTION_POINT_ENTRY(IID_IPropertyNotifySink)
CONNECTION_POINT_ENTRY(DIID__ITestControlEvents)
END_CONNECTION_POINT_MAP()
BEGIN_MSG_MAP(CTestControl)
CHAIN_MSG_MAP(CComControl<CTestControl>)
DEFAULT_REFLECTION_HANDLER()
MESSAGE_HANDLER(WM_LBUTTONDOWN, OnLButtonDown)
MESSAGE_HANDLER(WM_LBUTTONUP, OnLButtonUp)
MESSAGE_HANDLER(WM_MBUTTONDOWN, OnMButtonDown)
MESSAGE_HANDLER(WM_MBUTTONUP, OnMButtonUp)
MESSAGE_HANDLER(WM_RBUTTONDOWN, OnRButtonDown)
MESSAGE_HANDLER(WM_RBUTTONUP, OnRButtonUp)
MESSAGE_HANDLER(WM_MOUSEMOVE, OnMouseMove)
END_MSG_MAP()
// Handler prototypes:
// LRESULT MessageHandler(UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled);
// LRESULT CommandHandler(WORD wNotifyCode, WORD wID, HWND hWndCtl, BOOL& bHandled);
// LRESULT NotifyHandler(int idCtrl, LPNMHDR pnmh, BOOL& bHandled);
// IViewObjectEx
DECLARE_VIEW_STATUS(VIEWSTATUS_SOLIDBKGND | VIEWSTATUS_OPAQUE)
// ITestControl
public:
STDMETHOD(FloatTest)(double n1,double n2,/*[out,retval]*/double *n3);
STDMETHOD(UnsignedTest)(unsigned n1,unsigned n2,/*[out,retval]*/unsigned *n3);
STDMETHOD(ShortTest)(short int n1,short int n2,/*[out,retval]*/short int *n3);
STDMETHOD(StringTest)(BSTR s1,BSTR s2,/*[out,retval]*/BSTR *s3);
STDMETHOD(AddTest)(long n1,long *n2,/*[out,retval]*/long *n3);
STDMETHOD(get_Numprop)(long ndx,long *retVal);
STDMETHOD(put_Numprop)(long ndx,long newVal);
HRESULT OnDraw (ATL_DRAWINFO& di)
{
RECT& rc = *(RECT*)di.prcBounds;
Rectangle(di.hdcDraw, rc.left, rc.top, rc.right, rc.bottom);
SetTextAlign(di.hdcDraw, TA_CENTER|TA_BASELINE);
LPCTSTR pszText = _T("MysterX Test Control");
TextOut(di.hdcDraw,
(rc.left + rc.right) / 2,
(rc.top + rc.bottom) / 2,
pszText,
lstrlen(pszText));
return S_OK;
}
CComBSTR m_bstrCaption;
LRESULT OnLButtonDown(UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled)
{
Fire_MouseDown (0x1, wParam, GET_X_LPARAM (lParam), GET_Y_LPARAM (lParam));
Fire_Click();
return DefWindowProc (uMsg, wParam, lParam);
}
LRESULT OnLButtonUp(UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled)
{
Fire_MouseUp (0x1, wParam, GET_X_LPARAM (lParam), GET_Y_LPARAM (lParam));
return DefWindowProc (uMsg, wParam, lParam);
}
LRESULT OnMButtonDown (UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled)
{
Fire_MouseDown (0x4, wParam, GET_X_LPARAM (lParam), GET_Y_LPARAM (lParam));
Fire_Click();
return DefWindowProc (uMsg, wParam, lParam);
}
LRESULT OnMButtonUp (UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled)
{
Fire_MouseUp (0x4, wParam, GET_X_LPARAM (lParam), GET_Y_LPARAM (lParam));
return DefWindowProc (uMsg, wParam, lParam);
}
LRESULT OnRButtonDown (UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled)
{
Fire_MouseDown (0x2, wParam, GET_X_LPARAM (lParam), GET_Y_LPARAM (lParam));
Fire_Click();
return DefWindowProc(uMsg, wParam, lParam);
}
LRESULT OnRButtonUp (UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled)
{
Fire_MouseUp (0x2, wParam, GET_X_LPARAM (lParam), GET_Y_LPARAM (lParam));
return DefWindowProc (uMsg, wParam, lParam);
}
LRESULT OnMouseMove (UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled)
{
short button;
short shift;
button = wParam & (MK_LBUTTON | MK_MBUTTON | MK_RBUTTON);
shift = wParam & (MK_CONTROL | MK_SHIFT);
Fire_MouseMove (button, shift, GET_X_LPARAM (lParam), GET_Y_LPARAM (lParam));
return DefWindowProc (uMsg, wParam, lParam);
}
};
#endif //__TESTCONTROL_H_

34
collects/tests/mysterx/src/testcontrol.rgs
View File

@ -1,34 +0,0 @@
HKCR
{
Testobject.TestControl.1 = s 'TestControl Class'
{
CLSID = s '{FED8FE26-19CA-11D3-B5DB-0060089002FE}'
}
Testobject.TestControl = s 'TestControl Class'
{
CLSID = s '{FED8FE26-19CA-11D3-B5DB-0060089002FE}'
CurVer = s 'Testobject.TestControl.1'
}
NoRemove CLSID
{
ForceRemove {FED8FE26-19CA-11D3-B5DB-0060089002FE} = s 'TestControl Class'
{
ProgID = s 'Testobject.TestControl.1'
VersionIndependentProgID = s 'Testobject.TestControl'
ForceRemove 'Programmable'
InprocServer32 = s '%MODULE%'
{
val ThreadingModel = s 'Apartment'
}
ForceRemove 'Control'
ForceRemove 'Insertable'
ForceRemove 'ToolboxBitmap32' = s '%MODULE%, 101'
'MiscStatus' = s '0'
{
'1' = s '131473'
}
'TypeLib' = s '{07B31FF0-19EE-11D3-B5DB-0060089002FE}'
'Version' = s '1.0'
}
}
}

71
collects/tests/mysterx/src/testobject.cxx
View File

@ -1,71 +0,0 @@
// testobject.cpp : Implementation of DLL Exports.
// Note: Proxy/Stub Information
// To build a separate proxy/stub DLL,
// run nmake -f testobjectps.mk in the project directory.
#include "stdafx.h"
#include "resource.h"
#include <initguid.h>
#include "testobject.h"
#include "testobject_i.c"
#include "TestControl.h"
CComModule _Module;
BEGIN_OBJECT_MAP(ObjectMap)
OBJECT_ENTRY(CLSID_TestControl, CTestControl)
END_OBJECT_MAP()
/////////////////////////////////////////////////////////////////////////////
// DLL Entry Point
extern "C"
BOOL WINAPI DllMain (HINSTANCE hInstance, DWORD dwReason, LPVOID /*lpReserved*/)
{
if (dwReason == DLL_PROCESS_ATTACH) {
_Module.Init (ObjectMap, hInstance, &LIBID_TESTOBJECTLib);
DisableThreadLibraryCalls (hInstance);
}
else if (dwReason == DLL_PROCESS_DETACH)
_Module.Term();
return TRUE; // ok
}
/////////////////////////////////////////////////////////////////////////////
// Used to determine whether the DLL can be unloaded by OLE
STDAPI DllCanUnloadNow (void)
{
return (_Module.GetLockCount()==0) ? S_OK : S_FALSE;
}
/////////////////////////////////////////////////////////////////////////////
// Returns a class factory to create an object of the requested type
STDAPI DllGetClassObject (REFCLSID rclsid, REFIID riid, LPVOID* ppv)
{
return _Module.GetClassObject (rclsid, riid, ppv);
}
/////////////////////////////////////////////////////////////////////////////
// DllRegisterServer - Adds entries to the system registry
STDAPI DllRegisterServer (void)
{
// registers object, typelib and all interfaces in typelib
return _Module.RegisterServer (TRUE);
}
/////////////////////////////////////////////////////////////////////////////
// DllUnregisterServer - Removes entries from the system registry
STDAPI DllUnregisterServer (void)
{
return _Module.UnregisterServer (TRUE);
}

9
collects/tests/mysterx/src/testobject.def
View File

@ -1,9 +0,0 @@
; testobject.def : Declares the module parameters.
LIBRARY "testobject.DLL"
EXPORTS
DllCanUnloadNow PRIVATE
DllGetClassObject PRIVATE
DllRegisterServer PRIVATE
DllUnregisterServer PRIVATE

69
collects/tests/mysterx/src/testobject.idl
View File

@ -1,69 +0,0 @@
// testobject.idl : IDL source for testobject.dll
//
// This file will be processed by the MIDL tool to
// produce the type library (testobject.tlb) and marshalling code.
import "oaidl.idl";
import "ocidl.idl";
#include "olectl.h"
[
object,
uuid(07B31FFC-19EE-11D3-B5DB-0060089002FE),
dual,
helpstring("ITestControl Interface"),
pointer_default(unique)
]
interface ITestControl : IDispatch
{
[propput, id(DISPID_CAPTION)]
HRESULT Caption([in]BSTR strCaption);
[propget, id(DISPID_CAPTION)]
HRESULT Caption([out,retval]BSTR* pstrCaption);
[id(1), helpstring("method AddTest")] HRESULT AddTest(long n1,long *n2,[out,retval]long *n3);
[id(2), helpstring("method StringTest")] HRESULT StringTest(BSTR s1,BSTR s2,[out,retval]BSTR *s3);
[id(3), helpstring("method ShortTest")] HRESULT ShortTest(short int n1,short int n2,[out,retval]short int *n3);
[id(4), helpstring("method FloatTest")] HRESULT FloatTest(double n1,double n2,[out,retval]double *n3);
[id(5), helpstring("method UnsignedTest")] HRESULT UnsignedTest(unsigned n1,unsigned n2,[out,retval]unsigned *n3);
[propget, id(6), helpstring("property Numprop")] HRESULT Numprop(long ndx,[out, retval] long *pVal);
[propput, id(6), helpstring("property Numprop")] HRESULT Numprop(long ndx,[in] long newVal);
};
[
uuid(07B31FF0-19EE-11D3-B5DB-0060089002FE),
version(1.0),
helpstring("testobject 1.0 Type Library")
]
library TESTOBJECTLib
{
importlib("stdole32.tlb");
importlib("stdole2.tlb");
[
uuid(07B31FFD-19EE-11D3-B5DB-0060089002FE),
helpstring("_ITestControlEvents Interface")
]
dispinterface _ITestControlEvents
{
properties:
methods:
[id(DISPID_CLICK), helpstring("method Click")] HRESULT Click();
[id(DISPID_MOUSEDOWN), helpstring("method MouseDown")] HRESULT MouseDown(short button,short shift,OLE_XPOS_PIXELS x,OLE_YPOS_PIXELS y);
[id(DISPID_MOUSEUP), helpstring("method MouseUp")] HRESULT MouseUp(short button,short shift,OLE_XPOS_PIXELS x,OLE_YPOS_PIXELS y);
[id(1), helpstring("method KeyDown")] HRESULT KeyDown(short *keyCode,short shift);
[id(2), helpstring("method KeyUp")] HRESULT KeyUp(short *keyCode,short shift);
[id(3), helpstring("method MouseMove")] HRESULT MouseMove(short button,short shift,OLE_XPOS_PIXELS x,OLE_YPOS_PIXELS y);
};
[
uuid(FED8FE26-19CA-11D3-B5DB-0060089002FE),
helpstring("TestControl Class")
]
coclass TestControl
{
[default] interface ITestControl;
[default, source] dispinterface _ITestControlEvents;
};
};

46
collects/tests/mysterx/src/testobject.mak
View File

@ -1,46 +0,0 @@
# mysterx.mak
all : testobject.dll
clean :
-@erase testcontrol.obj
-@erase testobject.obj
-@erase testobject.dll
CPP=cl.exe
CPP_FLAGS=/MT /W3 /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "_ATL_STATIC_REGISTRY" /c
MTL=midl.exe
MTL_SWITCHES=/tlb testobject.tlb /h testobject.h /iid testobject_i.c /Oicf
RSC=rc.exe
RSC_PROJ=/l 0x409 /fo"testobject.res"
REGSVR32=regsvr32
.cxx.obj::
$(CPP) $(CPP_FLAGS) $<
LINK32=link.exe
LINK32_FLAGS= \
kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib \
advapi32.lib ole32.lib oleaut32.lib \
uuid.lib odbc32.lib odbccp32.lib \
/nologo /dll /subsystem:windows /incremental:no /machine:I386 \
/def:testobject.def /out:testobject.dll
DEF_FILE=testobject.def
LINK32_OBJS= \
testobject.obj testcontrol.obj testobject.res
testobject.dll : $(DEF_FILE) $(LINK32_OBJS)
$(LINK32) $(LINK32_FLAGS) $(LINK32_OBJS)
$(REGSVR32) /s testobject.dll
testcontrol.obj : testcontrol.cxx testobject.tlb stdafx.h
testobject.obj : testobject.cxx stdafx.h
testobject.tlb : testobject.idl
$(MTL) $(MTL_SWITCHES) testobject.idl
testcontrol.res : testcontrol.rc testcontrol.tlb
$(RSC) $(RSC_PROJ) testcontrol.rc

132
collects/tests/mysterx/src/testobject.rc
View File

@ -1,132 +0,0 @@
//Microsoft Developer Studio generated resource script.
//
#include "resource.h"
#define APSTUDIO_READONLY_SYMBOLS
/////////////////////////////////////////////////////////////////////////////
//
// Generated from the TEXTINCLUDE 2 resource.
//
#include "winres.h"
/////////////////////////////////////////////////////////////////////////////
#undef APSTUDIO_READONLY_SYMBOLS
/////////////////////////////////////////////////////////////////////////////
// English (U.S.) resources
#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_ENU)
#ifdef _WIN32
LANGUAGE LANG_ENGLISH, SUBLANG_ENGLISH_US
#pragma code_page(1252)
#endif //_WIN32
#ifdef APSTUDIO_INVOKED
/////////////////////////////////////////////////////////////////////////////
//
// TEXTINCLUDE
//
1 TEXTINCLUDE DISCARDABLE
BEGIN
"resource.h\0"
END
2 TEXTINCLUDE DISCARDABLE
BEGIN
"#include ""winres.h""\r\n"
"\0"
END
3 TEXTINCLUDE DISCARDABLE
BEGIN
"1 TYPELIB ""testobject.tlb""\r\n"
"\0"
END
#endif // APSTUDIO_INVOKED
#ifndef _MAC
/////////////////////////////////////////////////////////////////////////////
//
// Version
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 1,0,0,1
PRODUCTVERSION 1,0,0,1
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
#else
FILEFLAGS 0x0L
#endif
FILEOS 0x4L
FILETYPE 0x2L
FILESUBTYPE 0x0L
BEGIN
BLOCK "StringFileInfo"
BEGIN
BLOCK "040904B0"
BEGIN
VALUE "CompanyName", "\0"
VALUE "FileDescription", "testobject Module\0"
VALUE "FileVersion", "1, 0, 0, 1\0"
VALUE "InternalName", "testobject\0"
VALUE "LegalCopyright", "Copyright 1999\0"
VALUE "OriginalFilename", "testobject.DLL\0"
VALUE "ProductName", "testobject Module\0"
VALUE "ProductVersion", "1, 0, 0, 1\0"
VALUE "OLESelfRegister", "\0"
END
END
BLOCK "VarFileInfo"
BEGIN
VALUE "Translation", 0x409, 1200
END
END
#endif // !_MAC
/////////////////////////////////////////////////////////////////////////////
//
// Bitmap
//
IDB_TESTCONTROL BITMAP DISCARDABLE "testcont.bmp"
/////////////////////////////////////////////////////////////////////////////
//
// REGISTRY
//
IDR_TESTCONTROL REGISTRY DISCARDABLE "TestControl.rgs"
/////////////////////////////////////////////////////////////////////////////
//
// String Table
//
STRINGTABLE DISCARDABLE
BEGIN
IDS_PROJNAME "testobject"
END
#endif // English (U.S.) resources
/////////////////////////////////////////////////////////////////////////////
#ifndef APSTUDIO_INVOKED
/////////////////////////////////////////////////////////////////////////////
//
// Generated from the TEXTINCLUDE 3 resource.
//
1 TYPELIB "testobject.tlb"
/////////////////////////////////////////////////////////////////////////////
#endif // not APSTUDIO_INVOKED

179
collects/tests/mysterx/src/testobjectCP.h
View File

@ -1,179 +0,0 @@
#ifndef _TESTOBJECTCP_H_
#define _TESTOBJECTCP_H_
template <class T>
class CProxy_ITestControlEvents : public IConnectionPointImpl<T, &DIID__ITestControlEvents, CComDynamicUnkArray>
{
//Warning this class may be recreated by the wizard.
public:
HRESULT Fire_Click()
{
CComVariant varResult;
T* pT = static_cast<T*>(this);
int nConnectionIndex;
int nConnections = m_vec.GetSize();
for (nConnectionIndex = 0; nConnectionIndex < nConnections; nConnectionIndex++)
{
pT->Lock();
CComPtr<IUnknown> sp = m_vec.GetAt(nConnectionIndex);
pT->Unlock();
IDispatch* pDispatch = reinterpret_cast<IDispatch*>(sp.p);
if (pDispatch != NULL)
{
VariantClear(&varResult);
DISPPARAMS disp = { NULL, NULL, 0, 0 };
pDispatch->Invoke(DISPID_CLICK, IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, &disp, &varResult, NULL, NULL);
}
}
return varResult.scode;
}
HRESULT Fire_MouseDown(SHORT button, SHORT shift, OLE_XPOS_PIXELS x, OLE_YPOS_PIXELS y)
{
CComVariant varResult;
T* pT = static_cast<T*>(this);
int nConnectionIndex;
CComVariant* pvars = new CComVariant[4];
int nConnections = m_vec.GetSize();
for (nConnectionIndex = 0; nConnectionIndex < nConnections; nConnectionIndex++)
{
pT->Lock();
CComPtr<IUnknown> sp = m_vec.GetAt(nConnectionIndex);
pT->Unlock();
IDispatch* pDispatch = reinterpret_cast<IDispatch*>(sp.p);
if (pDispatch != NULL)
{
VariantClear(&varResult);
pvars[3] = button;
pvars[2] = shift;
pvars[1] = x;
pvars[0] = y;
DISPPARAMS disp = { pvars, NULL, 4, 0 };
pDispatch->Invoke(DISPID_MOUSEDOWN, IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, &disp, &varResult, NULL, NULL);
}
}
delete[] pvars;
return varResult.scode;
}
HRESULT Fire_MouseUp(SHORT button, SHORT shift, OLE_XPOS_PIXELS x, OLE_YPOS_PIXELS y)
{
CComVariant varResult;
T* pT = static_cast<T*>(this);
int nConnectionIndex;
CComVariant* pvars = new CComVariant[4];
int nConnections = m_vec.GetSize();
for (nConnectionIndex = 0; nConnectionIndex < nConnections; nConnectionIndex++)
{
pT->Lock();
CComPtr<IUnknown> sp = m_vec.GetAt(nConnectionIndex);
pT->Unlock();
IDispatch* pDispatch = reinterpret_cast<IDispatch*>(sp.p);
if (pDispatch != NULL)
{
VariantClear(&varResult);
pvars[3] = button;
pvars[2] = shift;
pvars[1] = x;
pvars[0] = y;
DISPPARAMS disp = { pvars, NULL, 4, 0 };
pDispatch->Invoke(DISPID_MOUSEUP, IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, &disp, &varResult, NULL, NULL);
}
}
delete[] pvars;
return varResult.scode;
}
HRESULT Fire_KeyDown(SHORT * keyCode, SHORT shift)
{
CComVariant varResult;
T* pT = static_cast<T*>(this);
int nConnectionIndex;
CComVariant* pvars = new CComVariant[2];
int nConnections = m_vec.GetSize();
for (nConnectionIndex = 0; nConnectionIndex < nConnections; nConnectionIndex++)
{
pT->Lock();
CComPtr<IUnknown> sp = m_vec.GetAt(nConnectionIndex);
pT->Unlock();
IDispatch* pDispatch = reinterpret_cast<IDispatch*>(sp.p);
if (pDispatch != NULL)
{
VariantClear(&varResult);
pvars[1] = keyCode;
pvars[0] = shift;
DISPPARAMS disp = { pvars, NULL, 2, 0 };
pDispatch->Invoke(0x1, IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, &disp, &varResult, NULL, NULL);
}
}
delete[] pvars;
return varResult.scode;
}
HRESULT Fire_KeyUp(SHORT *keyCode, SHORT shift)
{
CComVariant varResult;
T* pT = static_cast<T*>(this);
int nConnectionIndex;
CComVariant* pvars = new CComVariant[2];
int nConnections = m_vec.GetSize();
for (nConnectionIndex = 0; nConnectionIndex < nConnections; nConnectionIndex++)
{
pT->Lock();
CComPtr<IUnknown> sp = m_vec.GetAt(nConnectionIndex);
pT->Unlock();
IDispatch* pDispatch = reinterpret_cast<IDispatch*>(sp.p);
if (pDispatch != NULL)
{
VariantClear(&varResult);
pvars[1] = keyCode;
pvars[0] = shift;
DISPPARAMS disp = { pvars, NULL, 2, 0 };
pDispatch->Invoke(0x2, IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, &disp, &varResult, NULL, NULL);
}
}
delete[] pvars;
return varResult.scode;
}
HRESULT Fire_MouseMove(SHORT button, SHORT shift, OLE_XPOS_PIXELS x, OLE_YPOS_PIXELS y)
{
CComVariant varResult;
T* pT = static_cast<T*>(this);
int nConnectionIndex;
CComVariant* pvars = new CComVariant[4];
int nConnections = m_vec.GetSize();
for (nConnectionIndex = 0; nConnectionIndex < nConnections; nConnectionIndex++)
{
pT->Lock();
CComPtr<IUnknown> sp = m_vec.GetAt(nConnectionIndex);
pT->Unlock();
IDispatch* pDispatch = reinterpret_cast<IDispatch*>(sp.p);
if (pDispatch != NULL)
{
VariantClear(&varResult);
pvars[3] = button;
pvars[2] = shift;
pvars[1] = x;
pvars[0] = y;
DISPPARAMS disp = { pvars, NULL, 4, 0 };
pDispatch->Invoke(0x3, IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, &disp, &varResult, NULL, NULL);
}
}
delete[] pvars;
return varResult.scode;
}
};
#endif

112
collects/tests/mysterx/tests.rkt Normal file
View File

@ -0,0 +1,112 @@
#lang racket/base
(require mysterx
racket/system
setup/dirs
(only-in ffi/unsafe/com com-object-get-iunknown))
(define-syntax-rule (test expect expr)
(let ([val expr]
[ex expect])
(unless (equal? ex val)
(error 'test "~s failed: ~e" 'expr val))
(set! count (add1 count))))
(define count 0)
(when (eq? 'windows (system-type))
(system* (build-path (find-console-bin-dir) "MzCom.exe")
"/RegServer")
(define mzcom-progid (string-append "MzCOM.MzObj." (version)))
(define mzcom (cocreate-instance-from-progid mzcom-progid))
(test #t (com-object? mzcom))
(test #t (com-is-a? mzcom (com-object-type mzcom)))
(test (void) (set-coclass-from-progid! mzcom mzcom-progid))
(test #t (com-object-eq? mzcom mzcom))
(test '("About" "Eval" "Reset") (com-methods mzcom))
(test '("About" "Eval" "Reset") (com-methods (com-object-type mzcom)))
(test '(-> void) (com-method-type mzcom "About"))
(test '(-> void) (com-method-type (com-object-type mzcom) "About"))
(test '(-> void) (com-method-type mzcom "Reset"))
(test '(string -> string) (com-method-type mzcom "Eval"))
(test "3" (com-invoke mzcom "Eval" "(+ 1 2)"))
(test '() (com-get-properties mzcom))
(test '() (com-get-properties (com-object-type mzcom)))
(test '() (com-set-properties mzcom))
(test '() (com-set-properties (com-object-type mzcom)))
(test '("SchemeError") (com-events mzcom))
(test '("SchemeError") (com-events (com-object-type mzcom)))
(test #f (com-event-type mzcom "SchemeError"))
(test #f (com-event-type (com-object-type mzcom) "SchemeError"))
(define recved #f)
(test (void) (com-register-event-handler mzcom "SchemeError"
(lambda (msg) (set! recved msg))))
(test #t (with-handlers ([exn:fail? (lambda (exn)
(regexp-match? #rx"COM object exception"
(exn-message exn)))])
(com-invoke mzcom "Eval" "bad")))
(sync (system-idle-evt))
(test #t (regexp-match? #rx"bad" recved))
(test (void) (com-unregister-event-handler mzcom "SchemeError"))
(test #f (com-iunknown? mzcom))
(test #t (com-iunknown? (com-object-get-iunknown mzcom)))
(test com-omit com-omit)
(define ie (cocreate-instance-from-progid "InternetExplorer.Application.1"))
(test #t (and (member "Visible" (com-set-properties ie)) #t))
(test #f (com-get-property ie "Visible"))
(test (void) (com-set-property! ie "Visible" #t))
(test #t (com-get-property ie "Visible"))
(test (void) (com-set-property! ie "Visible" #f))
(test #f (com-get-property ie "Container"))
;; For IE 7 (or 8?), this needs to be a web page; opening
;; a local document disconnects the object for some reason:
(test (void) (com-invoke ie "Navigate" "http://racket-lang.org"))
(sleep 3) ; give the document time to load
(define doc (com-get-property ie "Document"))
(test #t (com-object? doc))
(test "Racket" (com-get-property ie "Document" "title"))
(test (void) (com-set-property! ie "Document" "title" "The Racket Documentation"))
(test "The Racket Documentation" (com-get-property ie "Document" "title"))
(test '(-> string) (com-get-property-type doc "title"))
(test '(string -> void) (com-set-property-type doc "title"))
(void))
(define (test-currency n)
(= (/ (round (* (inexact->exact n) 10000)) 10000)
(com-currency->number (number->com-currency n))))
(define (test-scode n)
(= n (com-scode->number (number->com-scode n))))
(define (test-date date)
(equal? date (com-date->date (date->com-date date))))
(for-each
(lambda (n)
(unless (test-scode n)
(eprintf "Error in test-scode for value ~a\n" n)))
'(25 -22 -1 -233344433 177000000 859489222))
(print-struct #t)
(let ([date (seconds->date (current-seconds))])
(unless (test-date date)
(eprintf "Error in test-date\n")))
(for-each
(lambda (n)
(unless (test-currency n)
(eprintf "Error in test-currency for value ~a\n" n)))
'(0 1 3.14 25.00 -22.34 11.7832 91000000000 25034343434.9933))
(printf "~a passed\n" count)

9
collects/tests/racket/com.rkt
View File

@ -110,12 +110,15 @@
(test #t (com-get-property ie "Visible"))
(test (void) (com-set-property! ie "Visible" #f))
(test #f (com-get-property ie "Container"))
(test (void) (com-invoke ie "Navigate" (format "file://~a"
(build-path (find-doc-dir) "index.html"))))
;; For IE 7 (or 8?), this needs to be a web page; opening
;; a local document disconnects the object for some reason:
(test (void) (com-invoke ie "Navigate" "http://racket-lang.org"))
(sleep 3) ; give the document time to load
(define doc (com-get-property ie "Document"))
(test #t (com-object? doc))
(test "Racket Documentation" (com-get-property ie "Document" "title"))
(test "Racket" (com-get-property ie "Document" "title"))
(test (void) (com-set-property! ie "Document" "title" "The Racket Documentation"))
(test "The Racket Documentation" (com-get-property ie "Document" "title"))
(test '(-> () string) (com-get-property-type doc "title"))

2
doc/release-notes/racket/HISTORY.txt
View File

@ -1,6 +1,8 @@
Version 5.2.1.6
Added prop:cpointer
Fixed handle-evt to disallow a handle-evt
mysterx: removed ActiveX support plus com-add-ref and
com-ref-count
Version 5.2.1.5
Added racket/future to re-exports of racket

8
src/get-libs.rkt
View File

@ -116,7 +116,13 @@
[win32/i386
["sqlite3.dll" 570947]]
[win32/x86_64
["sqlite3.dll" 617472]]]))
["sqlite3.dll" 617472]]]
;; COM libraries
'[com
[win32/i386
["myssink.dll" 92672]]
[win32/x86_64
["myssink.dll" 108032]]]))
(define-values [package dest-dir]
(let-values ([(args) (vector->list (current-command-line-arguments))])

6
src/myssink/.gitignore vendored Normal file
View File

@ -0,0 +1,6 @@
/myssink.h
/myssink_i.c
/myssink_p.c
/myssink.tlb
/myssink.res
/dlldata.c

0
src/mysterx/myssink/comtypes.cxx → src/myssink/comtypes.cxx
View File

0
src/mysterx/myssink/comtypes.h → src/myssink/comtypes.h
View File

0
src/mysterx/myssink/myssink.cxx → src/myssink/myssink.cxx
View File

0
src/mysterx/myssink/myssink.def → src/myssink/myssink.def
View File

0
src/mysterx/myssink/myssink.idl → src/myssink/myssink.idl
View File

0
src/mysterx/myssink/myssink.mak → src/myssink/myssink.mak
View File

29
src/myssink/myssink.manifest Normal file
View File

@ -0,0 +1,29 @@
<?xml version="1.0" encoding="UTF-8" standalone="no"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1"
manifestVersion="1.0">
<assemblyIdentity
type="win32"
name="myssink"
version="1.0.0.0" />
<file name="myssink.dll">
<comClass
clsid="{DA064DCD-0881-11D3-B5CA-0060089002FF}"
threadingModel="Apartment" />
<typelib tlbid="{DA064DC0-0881-11D3-B5CA-0060089002FF}"
version="1.0" helpdir=""/>
</file>
<comInterfaceExternalProxyStub
name="ISink"
iid="{DA064DCC-0881-11D3-B5CA-0060089002FF}"
proxyStubClsid32="{00020424-0000-0000-C000-000000000046}"
baseInterface="{00000000-0000-0000-C000-000000000046}"
tlbid="{DA064DC0-0881-11D3-B5CA-0060089002FF}" />
</assembly>

1
src/mysterx/myssink/myssink.rc → src/myssink/myssink.rc
View File

@ -122,3 +122,4 @@ END
/////////////////////////////////////////////////////////////////////////////
#endif // not APSTUDIO_INVOKED
CREATEPROCESS_MANIFEST_RESOURCE_ID RT_MANIFEST "myssink.manifest"

0
src/mysterx/myssink/myssinkps.def → src/myssink/myssinkps.def
View File

0
src/mysterx/myssink/resource.h → src/myssink/resource.h
View File

0
src/mysterx/myssink/sink.cxx → src/myssink/sink.cxx
View File

0
src/mysterx/myssink/sink.h → src/myssink/sink.h
View File

0
src/mysterx/myssink/sink.rgs → src/myssink/sink.rgs
View File

0
src/mysterx/myssink/sinktbl.h → src/myssink/sinktbl.h
View File

0
src/mysterx/myssink/stdafx.cxx → src/myssink/stdafx.cxx
View File

0
src/mysterx/myssink/stdafx.h → src/myssink/stdafx.h
View File

13
src/mysterx/.gitignore vendored
View File

@ -1,13 +0,0 @@
/myspage/myspage.h
/myspage/myspage_i.c
/myspage/myspage_p.c
/myspage/myspage.tlb
/myspage/myspage.res
/myspage/dlldata.c
/myssink/myssink.h
/myssink/myssink_i.c
/myssink/myssink_p.c
/myssink/myssink.tlb
/myssink/myssink.res
/myssink/dlldata.c

3
src/mysterx/README
View File

@ -1,3 +0,0 @@
This directory contains the MysterX source files.
See ..\worksp\README for build instructions.

431
src/mysterx/array.cxx
View File

@ -1,431 +0,0 @@
// array.cxx
#ifdef MYSTERX_3M
// Created by xform.rkt:
# include "xsrc/array3m.cxx"
#else
#include "mysterx_pre.h"
#include <objbase.h>
#include <mshtml.h>
#include <initguid.h>
#include <winnls.h>
#include <exdisp.h>
#include "escheme.h"
#include "bstr.h"
#include "myspage.h"
#include "myssink.h"
#include "mysterx.h"
Scheme_Object *safeArrayElementToSchemeObject(SAFEARRAY *theArray,
long *allIndices) {
HRESULT hr;
VARTYPE vt;
char errBuff[128];
hr = SafeArrayGetVartype(theArray,&vt);
if (hr != S_OK) codedComError("Can't get array type",hr);
switch(vt) {
case VT_EMPTY :
case VT_NULL :
return scheme_void;
case VT_UI1 :
char cArg;
SafeArrayGetElement(theArray,allIndices,&cArg);
return scheme_make_char(cArg);
case VT_UI2 :
unsigned short usArg;
SafeArrayGetElement(theArray,allIndices,&usArg);
return scheme_make_integer(usArg);
case VT_UI4 :
unsigned long ulArg;
SafeArrayGetElement(theArray,allIndices,&ulArg);
return scheme_make_integer_value_from_unsigned(ulArg);
case VT_UI8 :
ULARGE_INTEGER uli;
SafeArrayGetElement(theArray,allIndices, &uli.QuadPart);
return scheme_make_integer_value_from_unsigned_long_long(uli.QuadPart);
case VT_I1 :
char scArg;
SafeArrayGetElement(theArray,allIndices,&scArg);
return scheme_make_integer(scArg);
case VT_I2 :
int iArg;
SafeArrayGetElement(theArray,allIndices, &iArg);
return scheme_make_integer(iArg);
case VT_I4 :
long lArg;
SafeArrayGetElement(theArray,allIndices, &lArg);
return scheme_make_integer_value(lArg);
case VT_I8 :
LARGE_INTEGER li;
SafeArrayGetElement(theArray,allIndices, &li.QuadPart);
return scheme_make_integer_value_from_long_long(li.QuadPart);
case VT_R4 :
double dArg;
#ifdef MZ_USE_SINGLE_FLOATS
float fArg;
SafeArrayGetElement(theArray,allIndices, &fArg);
return scheme_make_float(fArg);
#else
SafeArrayGetElement(theArray,allIndices, &dArg);
return scheme_make_double((double)(dArg));
#endif
case VT_R8 :
SafeArrayGetElement(theArray,allIndices,&dArg);
return scheme_make_double((double)(dArg));
case VT_BSTR :
BSTR bArg;
SafeArrayGetElement(theArray,allIndices,&bArg);
return unmarshalBSTR(bArg);
case VT_ERROR :
SCODE scodeArg;
SafeArrayGetElement(theArray,allIndices,&scodeArg);
return mx_make_scode(scodeArg);
case VT_CY :
CY cyArg;
SafeArrayGetElement(theArray,allIndices,&cyArg);
return mx_make_cy(&cyArg);
case VT_DATE :
DATE dateArg;
SafeArrayGetElement(theArray,allIndices,&dateArg);
return mx_make_date(&dateArg);
case VT_DISPATCH :
IDispatch * pIDispatch;
SafeArrayGetElement(theArray,allIndices,&pIDispatch);
return mx_make_idispatch(pIDispatch);
case VT_UNKNOWN :
IUnknown *pIUnknown;
SafeArrayGetElement(theArray,allIndices,&pIUnknown);
return mx_make_iunknown(pIUnknown);
case VT_BOOL :
VARIANT_BOOL boolArg;
SafeArrayGetElement(theArray,allIndices,&boolArg);
return boolArg ? scheme_true : scheme_false;
case VT_VARIANT :
VARIANT variant;
SafeArrayGetElement(theArray,allIndices,&variant);
return variantToSchemeObject(&variant);
default :
sprintf(errBuff,
"Can't make Racket value from array element with type 0x%X",
vt);
scheme_signal_error(errBuff);
}
return NULL;
}
Scheme_Object *buildVectorFromArray(SAFEARRAY *theArray,
long currDim,
long *allIndices,
long *currNdx,
long offset) {
Scheme_Object *vec, *v;
long low,high,vecSize;
long i,j;
SafeArrayGetLBound(theArray,currDim,&low);
SafeArrayGetUBound(theArray,currDim,&high);
vecSize = high - low + 1;
vec = scheme_make_vector(vecSize,scheme_void);
if (currDim > 1) {
for (i = 0,j = low; i < vecSize; i++,j++) {
currNdx[offset] = j;
v = buildVectorFromArray(theArray, currDim - 1,
allIndices, currNdx, offset - 1);
SCHEME_VEC_ELS(vec)[i] = v;
}
}
else {
for (i = 0,j = low; i < vecSize; i++,j++) {
currNdx[offset] = j;
v = safeArrayElementToSchemeObject(theArray,allIndices);
SCHEME_VEC_ELS(vec)[i] = v;
}
}
return vec;
}
Scheme_Object *safeArrayToSchemeVector(SAFEARRAY *theArray) {
long numDims;
long *indices;
Scheme_Object *retval;
numDims = SafeArrayGetDim(theArray);
indices = (long *)scheme_malloc_atomic(numDims * sizeof(long));
retval = buildVectorFromArray(theArray,numDims,
indices, indices, numDims - 1);
return retval;
}
int getSchemeVectorDims(Scheme_Object *vec) {
Scheme_Object *currObj;
int numDims;
numDims = 0;
currObj = vec;
do {
numDims++;
currObj = SCHEME_VEC_ELS(currObj)[0];
} while (SCHEME_VECTORP(currObj));
return numDims;
}
void setArrayEltCounts(Scheme_Object *vec,
SAFEARRAYBOUND *rayBounds,long numDims) {
Scheme_Object *currObj;
long i;
currObj = vec;
i = numDims - 1;
do {
rayBounds[i--].cElements = SCHEME_VEC_SIZE(currObj);
currObj = SCHEME_VEC_ELS(currObj)[0];
} while (SCHEME_VECTORP(currObj));
}
BOOL isRegularVector(Scheme_Object *vec) {
Scheme_Object **elts,*elt;
BOOL isVec,zeroIsVec;
int len,currLen,zeroLen;
int i;
if (SCHEME_VECTORP(vec) == FALSE) return TRUE;
len = SCHEME_VEC_SIZE(vec);
elts = SCHEME_VEC_ELS(vec);
// use zeroth elt as standard
elt = elts[0];
zeroIsVec = SCHEME_VECTORP(elt);
if (zeroIsVec) zeroLen = SCHEME_VEC_SIZE(elt);
if (isRegularVector(elt) == FALSE) return FALSE;
for (i = 1; i < len; i++) {
elt = elts[i];
isVec = SCHEME_VECTORP(elt);
if (isVec != zeroIsVec) return FALSE;
if (isVec) {
currLen = SCHEME_VEC_SIZE(elt);
if (currLen != zeroLen) return FALSE;
if (isRegularVector(elt) == FALSE) return FALSE;
}
}
return TRUE;
}
void* variantDataPointer(VARTYPE vt,VARIANTARG *pVariantArg)
{
char errBuff[256];
switch (vt) {
case VT_NULL : return NULL;
case VT_I1 : return &pVariantArg->cVal;
case VT_I1 | VT_BYREF : return &pVariantArg->pcVal;
case VT_UI1 : return &pVariantArg->bVal;
case VT_UI1 | VT_BYREF : return &pVariantArg->pbVal;
case VT_I2 : return &pVariantArg->iVal;
case VT_I2 | VT_BYREF : return &pVariantArg->piVal;
case VT_UI2 : return &pVariantArg->uiVal;
case VT_UI2 | VT_BYREF : return &pVariantArg->puiVal;
case VT_I4 : return &pVariantArg->lVal;
case VT_I4 | VT_BYREF : return &pVariantArg->plVal;
case VT_UI4 : return &pVariantArg->ulVal;
case VT_UI4 | VT_BYREF : return &pVariantArg->pulVal;
case VT_INT : return &pVariantArg->intVal;
case VT_INT | VT_BYREF : return &pVariantArg->pintVal;
case VT_UINT : return &pVariantArg->uintVal;
case VT_UINT | VT_BYREF : return &pVariantArg->puintVal;
// VT_USERDEFINED in the typeDesc indicates an ENUM, but
// VT_USERDEFINED is illegal to use in the DISPPARAMS. The right
// thing to do is pass it as an INT. Note that we have to bash out
// the variant tag.
// ** NOTE THAT VT_USERDEFINED | VT_BYREF IS NOT
// ** A REFERENCE TO AN INT
case VT_USERDEFINED : return &pVariantArg->vt;
case VT_R4 : return &pVariantArg->fltVal;
case VT_R4 | VT_BYREF : return &pVariantArg->pfltVal;
case VT_R8 : return &pVariantArg->dblVal;
case VT_R8 | VT_BYREF : return &pVariantArg->pdblVal;
case VT_BSTR : return pVariantArg->bstrVal;
case VT_BSTR | VT_BYREF : return &pVariantArg->pbstrVal;
case VT_CY : return &pVariantArg->cyVal;
case VT_CY | VT_BYREF : return &pVariantArg->pcyVal;
case VT_DATE : return &pVariantArg->date;
case VT_DATE | VT_BYREF : return &pVariantArg->pdate;
case VT_BOOL : return &pVariantArg->boolVal;
case VT_BOOL | VT_BYREF : return &pVariantArg->pboolVal;
case VT_ERROR : return &pVariantArg->scode;
case VT_ERROR | VT_BYREF : return &pVariantArg->pscode;
case VT_DISPATCH : return pVariantArg->pdispVal;
case VT_DISPATCH | VT_BYREF : return &pVariantArg->ppdispVal;
// VT_USERDEFINED | VT_BYREF indicates that we should pass the
// IUnknown pointer of a COM object.
// VT_USERDEFINED | VT_BYREF is illegal in the DISPPARAMS, so we
// bash it out to VT_UNKNOWN.
case VT_USERDEFINED | VT_BYREF : return &pVariantArg->punkVal;
case VT_VARIANT | VT_BYREF : return &pVariantArg->pvarVal;
case VT_UNKNOWN : return pVariantArg->punkVal;
case VT_UNKNOWN | VT_BYREF : return &pVariantArg->ppunkVal;
case VT_VARIANT : return pVariantArg;
case VT_PTR :
scheme_signal_error("unable to marshal VT_PTR");
break;
default :
sprintf(errBuff, "Unable to marshal Racket value into VARIANT: 0x%X",
pVariantArg->vt);
scheme_signal_error(errBuff);
}
// Make the compiler happy
return pVariantArg;
}
VARTYPE schemeValueToCOMType(Scheme_Object* val)
{
if (SCHEME_CHARP(val)) return VT_UI1;
else if (SCHEME_EXACT_INTEGERP(val)) return VT_I4;
#ifdef MZ_USE_SINGLE_FLOATS
else if (SCHEME_FLTP(val)) return VT_R4;
#endif
else if (SCHEME_DBLP(val)) return VT_R8;
else if (SCHEME_STRSYMP(val)) return VT_BSTR;
else if (MX_CYP(val)) return VT_CY;
else if (MX_DATEP(val)) return VT_DATE;
else if (val == scheme_false) return VT_BOOL;
else if (val == scheme_true) return VT_BOOL;
else if (MX_SCODEP(val)) return VT_ERROR;
else if (MX_COM_OBJP(val)) return VT_DISPATCH;
else if (MX_IUNKNOWNP(val)) return VT_UNKNOWN;
else if (SCHEME_VECTORP(val)) return getSchemeVectorType(val);
else
scheme_signal_error("Unable to inject Racket value %V into VARIANT", val);
return VT_VARIANT;
}
void doSetArrayElts(Scheme_Object *vec, VARTYPE elementType, SAFEARRAY *theArray,
long *allIndices, long *currNdx, long offset) {
VARIANT variant;
Scheme_Object *elt;
int len;
int i;
len = SCHEME_VEC_SIZE(vec);
if (offset) {
for (i = 0; i < len; i++) {
elt = SCHEME_VEC_ELS(vec)[i];
currNdx[offset] = i;
doSetArrayElts(elt, elementType, theArray, allIndices,
currNdx, offset - 1);
}
} else {
for (i = 0; i < len; i++) {
elt = SCHEME_VEC_ELS(vec)[i];
currNdx[offset] = i;
marshalSchemeValueToVariant(elt,&variant);
if (variant.vt != elementType && elementType != VT_VARIANT) {
char errBuff[100];
sprintf(errBuff,
"Unable to put an element of COM type 0x%x into an array of COM type 0x%x",
variant.vt, elementType);
scheme_signal_error(errBuff);
}
SafeArrayPutElement(theArray, allIndices,
variantDataPointer(elementType,&variant));
}
}
}
void setArrayElts(Scheme_Object *vec, VARTYPE elementType, SAFEARRAY *theArray,
long numDims) {
long indices[MAXARRAYDIMS];
memset(indices,0,sizeof(indices));
doSetArrayElts(vec,elementType,theArray,indices,indices, numDims - 1);
}
// This doesn't work if we have an integer in a double array (or want
// a double array but have an integer vector). But it should work if
// we have doubles and integers (and return a VT_R8 array). Try to
// subtype it.
VARTYPE getSchemeVectorType(Scheme_Object *vec) {
VARTYPE type;
int i, size = SCHEME_VEC_SIZE(vec);
type = schemeValueToCOMType(SCHEME_VEC_ELS(vec)[0]);
if (VT_VARIANT == type) return type;
for (i = 1; i < size; ++i) {
if (type != schemeValueToCOMType(SCHEME_VEC_ELS(vec)[i]))
return VT_VARIANT;
}
return type;
}
SAFEARRAY *schemeVectorToSafeArray(Scheme_Object *vec, VARTYPE *vt) {
SAFEARRAY *theArray;
SAFEARRAYBOUND *rayBounds;
int numDims;
int i;
VARTYPE _vt;
if (SCHEME_VECTORP(vec) == FALSE)
scheme_signal_error("Can't convert non-vector to SAFEARRAY");
if (isRegularVector(vec) == FALSE)
scheme_signal_error("Can't convert irregular vector to SAFEARRAY");
numDims = getSchemeVectorDims(vec);
if (numDims > MAXARRAYDIMS)
scheme_signal_error("Too many array dimensions");
rayBounds = (SAFEARRAYBOUND *)malloc(numDims * sizeof(SAFEARRAYBOUND));
for (i = 0; i < numDims; i++) { rayBounds[i].lLbound = 0L; }
setArrayEltCounts(vec,rayBounds,numDims);
_vt = getSchemeVectorType(vec);
*vt = _vt;
theArray = SafeArrayCreate(*vt,numDims,rayBounds);
setArrayElts(vec,*vt,theArray,numDims);
return theArray;
}
#endif // MYSTERX_3M

4923
src/mysterx/bridge.cs
View File

File diff suppressed because it is too large Load Diff

488
src/mysterx/browser.cxx
View File

@ -1,488 +0,0 @@
// browser.cxx
#ifdef MYSTERX_3M
// Created by xform.rkt:
# include "xsrc/browser3m.cxx"
#else
#include "mysterx_pre.h"
#include <objbase.h>
#include <mshtml.h>
#include <initguid.h>
#include <winnls.h>
#include <exdisp.h>
#include <process.h>
#include "escheme.h"
#include "bstr.h"
#include "myspage.h"
#include "myssink.h"
#include "mysterx.h"
HWND browserHwnd;
/* we don't worry about overflow, since
Windows can't even create this many windows */
unsigned long browserCount;
static BOOL noBrowsersCache = TRUE;
BROWSER_WINDOW_STYLE_OPTION styleOptions[6] = {
// keep alphabetic for bsearch()
// { symbol,Win32 constant,TRUE=add/FALSE=remove }
{ "iconize",WS_ICONIC,TRUE },
{ "maximize",WS_MAXIMIZE,TRUE },
{ "no-system-menu",WS_CAPTION | WS_SYSMENU,FALSE },
{ "no-thick-border",WS_THICKFRAME,FALSE },
{ "scrollbars",WS_HSCROLL | WS_VSCROLL,TRUE },
};
int cmpBwso(char *key,BROWSER_WINDOW_STYLE_OPTION *bwso) {
return strcmp(key,bwso->name);
}
void assignIntOrDefault(int *pVal,Scheme_Object **argv,int argc,int ndx) {
if (SCHEME_SYMBOLP(argv[ndx])) {
*pVal = CW_USEDEFAULT;
if (strcmpi(SCHEME_SYM_VAL(argv[ndx]),"default") == 0) {
*pVal = CW_USEDEFAULT;
}
else {
scheme_wrong_type("make-document","int",ndx+1,argc,argv);
}
}
else if (SCHEME_INTP(argv[ndx]) == FALSE) {
scheme_wrong_type("make-browser","int",ndx+1,argc,argv);
}
else {
*pVal = SCHEME_INT_VAL(argv[ndx]);
}
}
typedef int (*COMP_PROC)(const void *,const void *);
Scheme_Object *mx_make_browser(int argc,Scheme_Object **argv) {
HRESULT hr;
MX_Browser_Object *browser;
IUnknown *pIUnknown;
IConnectionPointContainer *pIConnectionPointContainer;
IConnectionPoint *pIConnectionPoint;
ISink *pISink;
IDHTMLPage *pIDHTMLPage;
IStream *pIStream,*pBrowserStream;
IWebBrowser2 *pIWebBrowser2;
IEventQueue *pIEventQueue;
Scheme_Object *pSyms,*currSym, *cust, *v;
char *currStyleOption;
BROWSER_WINDOW_INIT browserWindowInit;
BROWSER_WINDOW_STYLE_OPTION *pBwso;
DWORD cookie;
LPSTR lbl;
int *destroy;
v = GUARANTEE_STRSYM ("make-browser", 0);
lbl = schemeToMultiByte (v);
browserWindowInit.browserWindow.label = lbl;
assignIntOrDefault(&browserWindowInit.browserWindow.width,argv,argc,1);
assignIntOrDefault(&browserWindowInit.browserWindow.height,argv,argc,2);
assignIntOrDefault(&browserWindowInit.browserWindow.x,argv,argc,3);
assignIntOrDefault(&browserWindowInit.browserWindow.y,argv,argc,4);
if (SCHEME_PAIRP(argv[5]) == FALSE && argv[5] != scheme_null) {
scheme_wrong_type("make-browser","list of symbols",5,argc,argv);
}
pSyms = argv[5];
browserWindowInit.browserWindow.style = WS_OVERLAPPEDWINDOW;
while (pSyms != scheme_null) {
currSym = SCHEME_CAR(pSyms);
if (SCHEME_SYMBOLP(currSym) == FALSE) {
scheme_wrong_type("make-browser","list of symbols",5,argc,argv);
}
currStyleOption = SCHEME_SYM_VAL(currSym);
pBwso = (BROWSER_WINDOW_STYLE_OPTION *)
bsearch(currStyleOption,
styleOptions,
sizeray(styleOptions),
sizeof(styleOptions[0]),
(COMP_PROC)cmpBwso);
if (pBwso == NULL) {
scheme_signal_error("Invalid browser window style option: %s",
currStyleOption);
}
if (pBwso->enable) {
browserWindowInit.browserWindow.style |= pBwso->bits;
}
else {
browserWindowInit.browserWindow.style &= ~(pBwso->bits);
}
pSyms = SCHEME_CDR(pSyms);
}
// mutex to protect association between new window and pIUnknown pointer to DHTML control
WaitForSingleObject(browserHwndMutex,INFINITE);
pBrowserStream = NULL;
browserWindowInit.ppIStream = &pBrowserStream;
browser = (MX_Browser_Object *)scheme_malloc_tagged(sizeof(MX_Browser_Object));
browser->so.type = mx_browser_type;
destroy = (int *)malloc(sizeof(int)); /* freed by msg loop */
*destroy = 0;
browserWindowInit.destroy = destroy;
browser->destroy = destroy;
// use _beginthread instead of CreateThread
// because the use of HTMLHelp requires the use of
// multithreaded C library
_beginthread(browserHwndMsgLoop,0,(void *)&browserWindowInit);
// wait until the window is created
WaitForSingleObject(createHwndSem,INFINITE);
browser->hwnd = browserHwnd;
if (!pBrowserStream)
scheme_signal_error ("make-browser: Can't create browser window");
hr = CoGetInterfaceAndReleaseStream(pBrowserStream,IID_IUnknown,(void **)&pIUnknown);
ReleaseSemaphore(browserHwndMutex,1,NULL);
if (hr != S_OK || pIUnknown == NULL) {
DestroyWindow(browserHwnd);
codedComError("make-browser: Can't get browser IUnknown interface",hr);
}
pIUnknown->QueryInterface(IID_IDHTMLPage,(void **)&pIDHTMLPage);
pIUnknown->Release();
if (pIDHTMLPage == NULL) {
scheme_signal_error("make-browser: Can't get IDHTMLPage interface");
}
// workaround for inability to use exdisp.idl or mshtml.idl
pIStream = NULL;
pIDHTMLPage->marshalWebBrowserToStream(&pIStream);
if (pIStream == NULL) {
scheme_signal_error("make-browser: Can't get pIStream interface for browser");
}
hr = CoGetInterfaceAndReleaseStream(pIStream,IID_IWebBrowser2,(void **)&pIWebBrowser2);
if (hr != S_OK || pIWebBrowser2 == NULL) {
codedComError("make-browser: Can't get IWebBrowser2 interface",hr);
}
pIStream = NULL;
pIDHTMLPage->marshalEventQueueToStream(&pIStream);
pIDHTMLPage->Release();
if (pIStream == NULL) {
scheme_signal_error("make-browser: Can't get IStream interface for event queue");
}
hr = CoGetInterfaceAndReleaseStream(pIStream,IID_IEventQueue,(void **)&pIEventQueue);
if (hr != S_OK || pIEventQueue == NULL) {
codedComError("make-browser: Can't get event queue interface",hr);
}
pIEventQueue->GetReaderSemaphore((long *)(&browser->readSem));
if (browser->readSem == 0) {
scheme_signal_error("make-browser: Error retrieving browser event read semaphore");
}
// setup event sink for browser
hr = pIWebBrowser2->QueryInterface(IID_IConnectionPointContainer,(void **)&pIConnectionPointContainer);
if (hr != S_OK || pIConnectionPointContainer == NULL) {
signalCodedEventSinkError("make-browser: Unable to get browser connection point container",hr);
}
hr = pIConnectionPointContainer->FindConnectionPoint(DIID_DWebBrowserEvents2,
&pIConnectionPoint);
if (hr != S_OK || pIConnectionPoint == NULL) {
signalCodedEventSinkError("make-browser: Unable to get browser connection point",hr);
}
pIConnectionPointContainer->Release();
hr = CoCreateInstance(CLSID_Sink,NULL,
CLSCTX_LOCAL_SERVER | CLSCTX_INPROC_SERVER,
IID_IUnknown,(void **)&pIUnknown);
if (hr != S_OK || pIUnknown == NULL) {
signalCodedEventSinkError("make-browser: Unable to create sink object",hr);
}
hr = pIUnknown->QueryInterface(IID_ISink,(void **)&pISink);
if (hr != S_OK || pISink == NULL) {
signalCodedEventSinkError("make-browser: Unable to find sink interface",hr);
}
pISink->set_myssink_table(&myssink_table);
hr = pIConnectionPoint->Advise(pIUnknown,&cookie);
pIUnknown->Release();
if (hr != S_OK) {
signalCodedEventSinkError("make-browser: Unable to connect sink to connection point",hr);
}
browser->pIWebBrowser2 = pIWebBrowser2;
browser->pISink = pISink;
browser->pIEventQueue = pIEventQueue;
cust = scheme_get_param(scheme_current_config(),MZCONFIG_CUSTODIAN);
scheme_add_managed((Scheme_Custodian *)cust,
(Scheme_Object *)browser,
(Scheme_Close_Custodian_Client *)scheme_release_browser,
(void *)TRUE,1);
++browserCount;
noBrowsersCache = FALSE;
return (Scheme_Object *)browser;
}
int browserExists(Scheme_Object *v) {
if (noBrowsersCache == TRUE) {
return TRUE;
}
if (browserCount == 0) {
noBrowsersCache = TRUE;
return TRUE;
}
return FALSE;
}
Scheme_Object *mx_block_while_browsers(int argc,Scheme_Object **argv) {
scheme_block_until(browserExists,NULL,NULL,1.0);
return scheme_void;
}
Scheme_Object *mx_navigate(int argc,Scheme_Object **argv) {
HRESULT hr;
IWebBrowser2 *pIWebBrowser2;
BSTR url;
VARIANT vars[4];
Scheme_Object *v;
v = GUARANTEE_BROWSER ("navigate", 0);
pIWebBrowser2 = MX_BROWSER_VAL (v);
v = GUARANTEE_STRSYM ("navigate", 1);
url = schemeToBSTR (v);
memset(vars,0,sizeof(vars));
hr = pIWebBrowser2->Navigate(url,vars,vars+1,vars+2,vars+3);
SysFreeString(url);
return (hr == S_OK) ? scheme_true : scheme_false;
}
Scheme_Object *mx_go_back(int argc,Scheme_Object **argv) {
IWebBrowser2 *pIWebBrowser2;
pIWebBrowser2 = MX_BROWSER_VAL (GUARANTEE_BROWSER ("go-back", 0));
return (pIWebBrowser2->GoBack() == S_OK) ? scheme_true : scheme_false;
}
Scheme_Object *mx_go_forward(int argc,Scheme_Object **argv) {
IWebBrowser2 *pIWebBrowser2;
pIWebBrowser2 = MX_BROWSER_VAL (GUARANTEE_BROWSER ("go-forward", 0));
return (pIWebBrowser2->GoForward() == S_OK) ? scheme_true : scheme_false;
}
Scheme_Object *mx_refresh(int argc,Scheme_Object **argv) {
HRESULT hr;
IWebBrowser2 *pIWebBrowser2;
pIWebBrowser2 = MX_BROWSER_VAL (GUARANTEE_BROWSER ("refresh", 0));
hr = pIWebBrowser2->Refresh();
return (hr == S_OK) ? scheme_true : scheme_false;
}
Scheme_Object *mx_show_browser_window(int argc,Scheme_Object **argv,
int cmd,char *s) {
HWND hwnd;
hwnd = MX_BROWSER_HWND (GUARANTEE_BROWSER (s, 0));
if (hwnd == NULL) {
scheme_signal_error("Browser has NULL window handle");
}
ShowWindow(hwnd,cmd);
return scheme_void;
}
Scheme_Object *mx_browser_show(int argc,Scheme_Object **argv) {
BOOL noShow;
noShow = (argv[1] == scheme_false);
browserCount += noShow ? -1 : 1;
return mx_show_browser_window(argc,argv,
noShow ? SW_HIDE : SW_SHOW,
"show");
}
Scheme_Object *mx_iconize(int argc,Scheme_Object **argv) {
return mx_show_browser_window(argc,argv,SW_MINIMIZE,"iconize");
}
Scheme_Object *mx_restore(int argc,Scheme_Object **argv) {
return mx_show_browser_window(argc,argv,SW_SHOWNORMAL,"restore");
}
Scheme_Object *mx_register_navigate_handler(int argc,Scheme_Object **argv) {
ISink *pISink;
pISink = MX_BROWSER_SINK (GUARANTEE_BROWSER ("register-navigate-handler", 0));
// register handler for NavigateComplete2 event (memID = 259)
pISink->register_handler(259, mx_wrap_handler(argv[1]));
return scheme_void;
}
IHTMLDocument2 *IHTMLDocument2FromBrowser(Scheme_Object *obj) {
HRESULT hr;
IWebBrowser2 *pIWebBrowser2;
IHTMLDocument2 *pIHTMLDocument2;
IDispatch *pIDispatch;
pIWebBrowser2 = MX_BROWSER_VAL(obj);
hr = pIWebBrowser2->get_Document(&pIDispatch);
if (hr != S_OK || pIDispatch == NULL) {
scheme_signal_error("Error retrieving DHTML dispatch interface");
}
hr = pIDispatch->QueryInterface(IID_IHTMLDocument2,(void **)&pIHTMLDocument2);
pIDispatch->Release();
if (hr != S_OK || pIHTMLDocument2 == NULL) {
codedComError("Error retrieving DHTML document2 interface",hr);
}
return pIHTMLDocument2;
}
Scheme_Object *mx_current_document(int argc,Scheme_Object **argv) {
IHTMLDocument2 *pIHTMLDocument2;
MX_Document_Object *doc;
Scheme_Object *v, *cust;
v = GUARANTEE_BROWSER ("current-document", 0);
pIHTMLDocument2 = IHTMLDocument2FromBrowser (v);
doc = (MX_Document_Object *)scheme_malloc_tagged(sizeof(MX_Document_Object));
doc->so.type = mx_document_type;
doc->pIHTMLDocument2 = pIHTMLDocument2;
cust = scheme_get_param(scheme_current_config(),MZCONFIG_CUSTODIAN);
scheme_add_managed((Scheme_Custodian *)cust,
(Scheme_Object *)doc,
(Scheme_Close_Custodian_Client *)scheme_release_document,
NULL,1);
return (Scheme_Object *)doc;
}
Scheme_Object *mx_print(int argc,Scheme_Object **argv) {
HRESULT hr;
IWebBrowser2 *pIWebBrowser2;
VARIANT varIn, varOut;
Scheme_Object *v;
v = GUARANTEE_BROWSER ("print", 0);
pIWebBrowser2 = MX_BROWSER_VAL (v);
VariantInit(&varIn);
VariantInit(&varOut);
hr = pIWebBrowser2->ExecWB(OLECMDID_PRINT,
OLECMDEXECOPT_DONTPROMPTUSER,
&varIn,&varOut);
if (hr != S_OK) {
codedComError("print: Error printing",hr);
}
return scheme_void;
}
Scheme_Object *mx_current_url(int argc,Scheme_Object **argv) {
HRESULT hr;
IWebBrowser2 *pIWebBrowser2;
IHTMLDocument2 *pIHTMLDocument2;
BSTR url;
Scheme_Object *retval;
pIWebBrowser2 = MX_BROWSER_VAL (GUARANTEE_BROWSER ("current-url", 0));
pIHTMLDocument2 = IHTMLDocument2FromBrowser(argv[0]);
hr = pIHTMLDocument2->get_URL(&url);
pIHTMLDocument2->Release();
if (hr != S_OK) {
codedComError("current-url: Error retrieving URL",hr);
}
if (url == NULL) {
scheme_signal_error("current-url: NULL URL");
}
retval = BSTRToSchemeString(url);
SysFreeString(url);
return retval;
}
#endif // MYSTERX_3M

384
src/mysterx/bstr.cxx
View File

@ -1,384 +0,0 @@
// bstr.cxx -- BSTR utility functions
#ifdef MYSTERX_3M
// Created by xform.rkt:
# include "xsrc/bstr3m.cxx"
#else
#include "mysterx_pre.h"
#include <windows.h>
/* This indirection lets us delayload libmzsch.dll: */
#define scheme_false (scheme_make_false())
typedef unsigned short *pushort;
// fwd ref
BSTR schemeToBSTR (Scheme_Object * obj);
static
LPWSTR schemeUCS4ToUTF16 (const mzchar * buffer, int nchars, long * result_length)
{
LPWSTR s;
intptr_t rl;
s = (LPWSTR) scheme_ucs4_to_utf16 (buffer, 0, nchars, NULL, 0, &rl, 1);
*result_length = rl;
s[*result_length] = 0;
return s;
}
static
LPWSTR schemeUTF8ToUTF16 (const unsigned char * buffer, int buflen, long * result_length)
{
intptr_t nchars;
mzchar * ucs4;
ucs4 = scheme_utf8_decode_to_buffer_len (buffer, buflen, NULL, 0, &nchars);
return schemeUCS4ToUTF16 (ucs4, nchars, result_length);
}
static
LPWSTR schemeByteStringToWideChar (Scheme_Object * obj, long * result_length)
{
return
schemeUTF8ToUTF16 ((unsigned char *)SCHEME_BYTE_STR_VAL (obj),
SCHEME_BYTE_STRLEN_VAL (obj),
result_length);
}
static
LPWSTR schemeCharStringToWideChar (Scheme_Object * obj, long * result_length)
{
return schemeUCS4ToUTF16(SCHEME_CHAR_STR_VAL (obj),
SCHEME_CHAR_STRLEN_VAL (obj),
result_length);
}
static
LPWSTR schemeSymbolToWideChar (Scheme_Object * obj, long * result_length)
{
return
schemeUTF8ToUTF16 ((unsigned char *)SCHEME_SYM_VAL (obj),
SCHEME_SYM_LEN (obj),
result_length);
}
static
BSTR schemeByteStringToBSTR (Scheme_Object * obj)
{
long nchars;
LPCWSTR widestring;
widestring = schemeByteStringToWideChar (obj, &nchars);
return SysAllocStringLen (widestring, nchars);
}
static
BSTR schemeCharStringToBSTR (Scheme_Object * obj)
{
long nchars;
LPCWSTR widestring;
widestring= schemeCharStringToWideChar (obj, &nchars);
return SysAllocStringLen (widestring, nchars);
}
static
BSTR schemeSymbolToBSTR (Scheme_Object * obj)
{
return
schemeToBSTR (scheme_make_sized_offset_utf8_string (SCHEME_SYM_VAL(obj),
0,
SCHEME_SYM_LEN(obj)));
}
static
LPSTR schemeWideStringToMultiByte (LPCWSTR string, long nchars)
{
int chars_needed;
LPSTR result;
chars_needed = WideCharToMultiByte (CP_ACP, 0, string, nchars, NULL, 0, NULL, NULL);
result = (LPSTR) scheme_malloc_atomic (chars_needed + 1);
WideCharToMultiByte (CP_ACP, 0, string, nchars, result, chars_needed, NULL, NULL);
result [chars_needed] = '\0';
return result;
}
static
LPSTR schemeByteStringToMultiByte (Scheme_Object * obj)
{
long nchars;
LPCWSTR unicode;
unicode = schemeByteStringToWideChar (obj, &nchars);
return schemeWideStringToMultiByte (unicode, nchars);
}
static
LPSTR schemeCharStringToMultiByte (Scheme_Object * obj)
{
long nchars;
LPCWSTR unicode;
unicode = schemeCharStringToWideChar (obj, &nchars);
return schemeWideStringToMultiByte (unicode, nchars);
}
static
LPSTR schemeSymbolToMultiByte (Scheme_Object * obj)
{
long nchars;
LPCWSTR unicode;
unicode = schemeSymbolToWideChar (obj, &nchars);
return schemeWideStringToMultiByte (unicode, nchars);
}
Scheme_Object * multiByteToSchemeCharString (const char * mbstr)
{
int len;
WCHAR * wide;
HRESULT hr;
intptr_t nchars;
mzchar * ucs4;
len = (int) strlen (mbstr);
wide = (WCHAR *)scheme_malloc_atomic (len * sizeof (WCHAR));
hr = MultiByteToWideChar (CP_ACP, (DWORD)0, mbstr, len, wide, len);
if (hr == 0 && len > 0)
scheme_signal_error("Error translating string parameter to Unicode");
ucs4 = scheme_utf16_to_ucs4 ((pushort)wide, 0, len, NULL, 0, &nchars, 0);
return scheme_make_sized_char_string (ucs4, nchars, 0);
}
static
BSTR multiByteToBSTR (LPCSTR text, UINT len)
{
BSTR bstr;
bstr = SysAllocStringLen (NULL, len);
if (bstr == NULL)
scheme_signal_error ("Error allocating string parameter");
if (MultiByteToWideChar (CP_ACP, (DWORD)0,
text, len,
bstr, len) == 0
&& len > 0)
scheme_signal_error ("Error translating string parameter to WideChar");
return bstr;
}
BSTR textToBSTR (LPCTSTR text, size_t length)
{
#ifdef UNICODE
return SysAllocStringLen (text, length);
#else
return multiByteToBSTR (text, length);
#endif
}
Scheme_Object * BSTRToSchemeString (BSTR bstr)
{
UINT length;
intptr_t nchars;
mzchar * string;
length = SysStringLen (bstr);
string = scheme_utf16_to_ucs4 ((pushort)bstr, 0, length,
NULL, 0,
&nchars, 0);
return scheme_make_sized_char_string (string, nchars, 0);
}
Scheme_Object * LPOLESTRToSchemeString (LPOLESTR str)
{
UINT length;
intptr_t nchars;
mzchar * string;
length = wcslen (str);
string = scheme_utf16_to_ucs4 ((pushort)str, 0, length,
NULL, 0,
&nchars, 0);
return scheme_make_sized_char_string (string, nchars, 0);
}
Scheme_Object * BSTRToSchemeSymbol (BSTR bstr)
{
UINT length;
intptr_t nchars;
mzchar * string;
length = SysStringLen (bstr);
string = scheme_utf16_to_ucs4 ((pushort)bstr, 0, length,
NULL, 0,
&nchars, 0);
return scheme_intern_exact_char_symbol (string, nchars);
}
Scheme_Object * unmarshalBSTR (BSTR bstr)
{
return BSTRToSchemeString (bstr);
}
static
void updateSchemeByteStringFromBSTR (Scheme_Object * obj, BSTR bstr)
{
UINT len;
intptr_t nchars;
mzchar * string;
intptr_t ncodes;
len = SysStringLen (bstr);
string = scheme_utf16_to_ucs4 ((pushort)bstr, 0, len,
NULL, 0,
&nchars, 0);
if (nchars > SCHEME_BYTE_STRLEN_VAL(obj))
scheme_signal_error ("String updated with longer string");
scheme_utf8_encode_to_buffer_len (string, nchars,
SCHEME_BYTE_STR_VAL(obj), SCHEME_BYTE_STRLEN_VAL(obj),
&ncodes);
SCHEME_BYTE_STRLEN_VAL(obj) = ncodes;
}
static
void updateSchemeCharStringFromBSTR (Scheme_Object * obj, BSTR bstr)
{
UINT len;
intptr_t ulen;
len = SysStringLen (bstr);
if (len > (unsigned int)SCHEME_CHAR_STRLEN_VAL(obj))
scheme_signal_error("String updated with longer string");
scheme_utf16_to_ucs4 ((pushort)bstr, 0, len,
SCHEME_CHAR_STR_VAL(obj), SCHEME_CHAR_STRLEN_VAL(obj),
&ulen, 0);
SCHEME_CHAR_STRLEN_VAL(obj) = ulen;
}
static
void updateSchemeSymbolFromBSTR (Scheme_Object *, BSTR)
{
scheme_signal_error ("Symbol cannot be updated from BSTR.");
}
void updateSchemeFromBSTR (Scheme_Object *obj, BSTR bstr)
{
if (SCHEME_SYMBOLP (obj))
updateSchemeSymbolFromBSTR (obj, bstr);
else if (SCHEME_CHAR_STRINGP (obj))
updateSchemeCharStringFromBSTR (obj, bstr);
else if (SCHEME_BYTE_STRINGP (obj))
updateSchemeByteStringFromBSTR (obj, bstr);
else if (SCHEME_PATHP (obj))
updateSchemeByteStringFromBSTR (obj, bstr);
else {
scheme_signal_error ("updateSchemeFromBSTR: argument is not a symbol, char string, or byte string");
}
}
BSTR stringToBSTR (LPCSTR s, size_t len)
{
BSTR bstr;
bstr = SysAllocStringLen (NULL, len);
if (bstr == NULL)
scheme_signal_error ("Error allocating string parameter");
if (MultiByteToWideChar (CP_ACP, (DWORD)0,
s, len,
bstr, len) == 0
&& len > 0)
scheme_signal_error ("Error translating string parameter to WideChar");
return bstr;
}
LPTSTR schemeCharStringToText (Scheme_Object * obj)
{
#if UNICODE
return schemeCharStringToWideChar (obj);
#else
return schemeCharStringToMultiByte (obj);
#endif
}
LPTSTR schemeSymbolToText (Scheme_Object * obj)
{
#if UNICODE
return schemeSymbolToWideChar (obj);
#else
return schemeSymbolToMultiByte (obj);
#endif
}
// Returns a pointer to a Microsoft encoded MultiByte string.
LPSTR schemeToMultiByte (Scheme_Object * obj)
{
if (SCHEME_SYMBOLP (obj))
return schemeSymbolToMultiByte (obj);
else if (SCHEME_CHAR_STRINGP (obj))
return schemeCharStringToMultiByte(obj);
else if (SCHEME_BYTE_STRINGP (obj))
return schemeByteStringToMultiByte(obj);
else if (SCHEME_PATHP (obj))
return schemeByteStringToMultiByte(obj);
else {
scheme_signal_error ("schemeToMultiByte: argument is not a symbol, char string, or byte string");
return NULL;
}
}
// Returns a pointer to a Microsoft encoded string suitable for
// passing to OLE and COM.
BSTR schemeToBSTR (Scheme_Object * obj)
{
if (SCHEME_SYMBOLP (obj))
return schemeSymbolToBSTR (obj);
else if (SCHEME_CHAR_STRINGP (obj))
return schemeCharStringToBSTR (obj);
else if (SCHEME_BYTE_STRINGP (obj))
return schemeByteStringToBSTR (obj);
else if (SCHEME_PATHP (obj))
return schemeByteStringToBSTR (obj);
else {
scheme_signal_error ("schemeToBSTR: argument is not a symbol, char string, or byte string");
return NULL;
}
}
// Returns a pointer to a Microsoft encoded string. String will be
// either WideChar or MultiByte depending on compilation flag.
LPTSTR schemeToText (Scheme_Object * obj)
{
#ifdef UNICODE
return schemeToWideChar (obj);
#else
return schemeToMultiByte (obj);
#endif
}
// Returns a pointer to a Microsoft WideChar-encoded string.
LPWSTR schemeToWideChar (Scheme_Object * obj)
{
long result_length;
if (SCHEME_SYMBOLP (obj))
return schemeSymbolToWideChar (obj, &result_length);
else if (SCHEME_CHAR_STRINGP (obj))
return schemeCharStringToWideChar (obj, &result_length);
else if (SCHEME_BYTE_STRINGP (obj))
return schemeByteStringToWideChar (obj, &result_length);
if (SCHEME_PATHP(obj))
return schemeByteStringToWideChar (obj, &result_length);
else {
scheme_signal_error ("schemeToWideChar: argument is not a symbol, char string, or byte string");
return NULL;
}
}
#endif //MYSTERX_3M

24
src/mysterx/bstr.h
View File

@ -1,24 +0,0 @@
// bstr.h
BSTR textToBSTR (LPCTSTR, size_t);
// conversions to and from Windows types.
BSTR schemeToBSTR (Scheme_Object *);
LPSTR schemeToMultiByte (Scheme_Object *);
LPTSTR schemeToText (Scheme_Object *);
LPWSTR schemeToWideChar (Scheme_Object *);
LPTSTR schemeCharStringToText (Scheme_Object *);
LPTSTR schemeSymbolToText (Scheme_Object *);
Scheme_Object * multiByteToSchemeCharString (LPCSTR);
Scheme_Object * textToSchemeCharString (LPCTSTR);
Scheme_Object * textToSchemeSymbol (LPCTSTR);
extern Scheme_Object * mx_unmarshal_strings_as_symbols;
Scheme_Object *BSTRToSchemeString(BSTR);
void updateSchemeFromBSTR(Scheme_Object *,BSTR);
BSTR stringToBSTR(const char *,size_t);
Scheme_Object * unmarshalBSTR (BSTR bstr);
Scheme_Object * LPOLESTRToSchemeString (LPOLESTR str);

464
src/mysterx/comtypes.cxx
View File

@ -1,464 +0,0 @@
// comtypes.cxx
#ifdef MYSTERX_3M
// Created by xform.rkt:
# include "xsrc/comtypes3m.cxx"
#else
#include "mysterx_pre.h"
#include <assert.h>
#include <stdio.h>
#include <malloc.h>
#include <float.h>
#include <objbase.h>
#include <mshtml.h>
#include <initguid.h>
#include <winnls.h>
#include <exdisp.h>
#include "myspage.h"
#include "myssink.h"
#include "mysterx.h"
Scheme_Type mx_com_object_type;
Scheme_Type mx_com_type_type;
Scheme_Type mx_browser_type;
Scheme_Type mx_document_type;
Scheme_Type mx_element_type;
Scheme_Type mx_event_type;
Scheme_Type mx_com_cy_type;
Scheme_Type mx_com_date_type;
Scheme_Type mx_com_scode_type;
Scheme_Type mx_com_iunknown_type;
Scheme_Type mx_com_omit_type;
Scheme_Type mx_com_typedesc_type;
Scheme_Type mx_tbl_entry_type;
Scheme_Object *mx_document_pred(int argc,Scheme_Object **argv)
{
return MX_DOCUMENTP (argv[0]) ? scheme_true : scheme_false;
}
Scheme_Object *mx_make_cy (CY *pCy)
{
MX_COM_Data_Object *retval;
retval = (MX_COM_Data_Object *)scheme_malloc_atomic_tagged (sizeof (MX_COM_Data_Object));
retval->so.type = mx_com_cy_type;
retval->cy = *pCy;
return (Scheme_Object *)retval;
}
Scheme_Object *mx_make_date (DATE *pDate)
{
MX_COM_Data_Object *retval;
retval = (MX_COM_Data_Object *)scheme_malloc_atomic_tagged (sizeof (MX_COM_Data_Object));
retval->so.type = mx_com_date_type;
retval->date = *pDate;
return (Scheme_Object *)retval;
}
Scheme_Object *mx_make_bool(unsigned boolVal)
{
return (boolVal == 0) ? scheme_false : scheme_true;
}
Scheme_Object *mx_make_scode(SCODE scode)
{
MX_COM_Data_Object *retval;
retval = (MX_COM_Data_Object *)scheme_malloc_atomic_tagged (sizeof (MX_COM_Data_Object));
retval->so.type = mx_com_scode_type;
retval->scode = scode;
return (Scheme_Object *)retval;
}
Scheme_Object *mx_make_idispatch(IDispatch *pIDispatch)
{
MX_COM_Object *retval;
if (pIDispatch == NULL) return scheme_false;
retval = (MX_COM_Object *)scheme_malloc_tagged(sizeof(MX_COM_Object));
retval->so.type = mx_com_object_type;
retval->pIDispatch = pIDispatch;
retval->clsId = emptyClsId;
retval->pITypeInfo = NULL;
retval->pEventTypeInfo = NULL;
retval->pIConnectionPoint = NULL;
retval->pISink = NULL;
retval->connectionCookie = (DWORD)0;
retval->released = FALSE;
mx_register_com_object((Scheme_Object *)retval,pIDispatch);
return (Scheme_Object *)retval;
}
Scheme_Object *mx_make_iunknown(IUnknown *pIUnknown) {
IDispatch * pIDispatch = NULL;
IUnknown * pUnk = NULL;
HRESULT hr;
MX_COM_Data_Object *retval;
// Ensure we have the canonical iunknown!
pIUnknown->QueryInterface (IID_IUnknown, (void **)&pUnk);
pIUnknown->Release();
// Try to get Dispatch pointer
hr = pUnk->QueryInterface (IID_IDispatch, (void **)&pIDispatch);
if (SUCCEEDED (hr)) {
pUnk->Release();
return mx_make_idispatch (pIDispatch);
}
// DebugBreak();
retval = (MX_COM_Data_Object *)scheme_malloc_tagged(sizeof(MX_COM_Data_Object));
retval->so.type = mx_com_iunknown_type;
retval->released = FALSE;
retval->pIUnknown = pUnk;
mx_register_simple_com_object ((Scheme_Object *)retval, pUnk);
return (Scheme_Object *)retval;
}
BOOL mx_cy_pred(Scheme_Object *obj) {
return MX_CYP(obj);
}
Scheme_Object *mx_cy_pred_ex(int argc,Scheme_Object **argv) {
return mx_cy_pred(argv[0]) ? scheme_true : scheme_false;
}
BOOL mx_date_pred(Scheme_Object *obj) {
return MX_DATEP(obj);
}
Scheme_Object *mx_date_pred_ex(int argc,Scheme_Object **argv) {
return mx_date_pred(argv[0]) ? scheme_true : scheme_false;
}
BOOL mx_scode_pred(Scheme_Object *obj) {
return MX_SCODEP(obj);
}
Scheme_Object *mx_scode_pred_ex (int argc,Scheme_Object **argv)
{
return mx_scode_pred(argv[0]) ? scheme_true : scheme_false;
}
BOOL mx_comobj_pred (Scheme_Object *obj)
{
return MX_COM_OBJP(obj);
}
Scheme_Object *mx_comobj_pred_ex(int argc,Scheme_Object **argv)
{
return mx_comobj_pred (argv[0]) ? scheme_true : scheme_false;
}
BOOL mx_iunknown_pred(Scheme_Object *obj)
{
return MX_IUNKNOWNP(obj);
}
Scheme_Object *mx_iunknown_pred_ex(int argc,Scheme_Object **argv)
{
return mx_iunknown_pred (argv[0]) ? scheme_true : scheme_false;
}
CY mx_cy_val (Scheme_Object *obj)
{
return MX_CY_VAL(obj);
}
Scheme_Object *mx_currency_to_scheme_number(int argc,Scheme_Object **argv)
{
GC_CAN_IGNORE CY cy;
char buff[40];
int len;
Scheme_Object *port, *v;
v = GUARANTEE_CY ("com-currency->number", 0);
cy = MX_CY_VAL (v);
sprintf(buff,"%I64d",cy);
len = (int)strlen(buff);
// divide by 10,000 by shifting digits
if (len > 4) {
memmove(buff + len - 3,buff + len - 4,4);
buff[len - 4] = '.';
buff[len + 1] = '\0';
}
else if (len > 0) {
int i;
memmove(buff + 5 - len,buff,len);
buff[0] = '.';
for (i = 1; i < 5 - len; i++) {
buff[i] = '0';
}
buff[6-len] = '\0';
}
else {
buff[0] = '0';
buff[1] = '\0';
}
port = scheme_make_byte_string_input_port(buff);
return scheme_read(port);
}
BOOL lt64 (_int64 n1,_int64 n2)
{
return n1 < n2;
}
BOOL gt64 (_int64 n1,_int64 n2)
{
return n1 > n2;
}
_int64 add64(_int64 n,int m)
{
return n + m;
}
_int64 sub64(_int64 n,int m)
{
return n - m;
}
_int64 scanNum64(char *s,_int64 (*combine)(_int64,int),
BOOL (*cmp)(_int64,_int64),Scheme_Object *obj) {
_int64 cy,last;
last = cy = 0;
while (*s) {
cy *= 10;
cy = combine(cy,(*s) - '0');
if (cmp(cy,last))
scheme_signal_error("number->com-currency: "
"number %V too big to fit in com-currency",
obj);
last = cy;
s = s XFORM_OK_PLUS 1;
}
return cy;
}
Scheme_Object *scheme_number_to_mx_currency(int argc,Scheme_Object **argv) {
char *p,*q,*r,*s;
char buff[40];
_int64 cy;
int neededZeroes;
int len;
int i;
if (SCHEME_EXACT_INTEGERP(argv[0]) == FALSE &&
SCHEME_FLOATP(argv[0]) == FALSE)
scheme_wrong_type("number->com-currency","exact or inexact number",0,argc,argv);
s = scheme_display_to_string(argv[0],NULL);
strncpy(buff,s,sizeof(buff)-1);
buff[min(strlen(s),sizeof(buff))] = '\0';
// multiply by 10,000
len = (int)strlen(buff);
p = strchr(buff,'.');
if (p) {
int numDecimals;
numDecimals = (int)(buff - p) + (len - 1);
neededZeroes = max(4 - numDecimals,0);
memmove(p,p+1,min(numDecimals,4));
q = p XFORM_OK_PLUS numDecimals;
}
else {
q = buff + len;
neededZeroes = 4;
}
for (i = 0; i < neededZeroes; i++) {
*q = '0';
q = q XFORM_OK_PLUS 1;
}
*q = '\0';
r = buff;
cy = ((*r) == '-')
? scanNum64 (r XFORM_OK_PLUS 1, sub64, gt64, argv[0])
: scanNum64 (r, add64, lt64, argv[0]);
return mx_make_cy((CY *)&cy);
}
DATE mx_date_val (Scheme_Object *obj)
{
return MX_DATE_VAL (obj);
}
BOOL isLeapYear(int year)
{
return
(year % 4) ? FALSE
: (year % 400) ? TRUE
: (year % 100) ? FALSE
: TRUE;
}
static int offsets[12] =
{ 0, // Jan
31, // Feb
59, // Mar
90, // Apr
120, // May
151, // Jun
181, // Jul
212, // Aug
243, // Sept
273, // Oct
304, // Nov
334, // Dec
};
Scheme_Object *mx_date_to_scheme_date(int argc,Scheme_Object **argv) {
SYSTEMTIME sysTime;
Scheme_Object *p[10], *date_type;
int yearDay;
GUARANTEE_DATE ("date->com-date", 0);
if (VariantTimeToSystemTime(MX_DATE_VAL(argv[0]),&sysTime) == FALSE)
scheme_signal_error("com-date->date: error in conversion");
yearDay = offsets[sysTime.wMonth - 1] + sysTime.wDay;
yearDay--; /* because 0-based */
if (sysTime.wMonth > 2 && isLeapYear(sysTime.wYear))
yearDay++;
p[0] = scheme_make_integer(sysTime.wSecond);
p[1] = scheme_make_integer(sysTime.wMinute);
p[2] = scheme_make_integer(sysTime.wHour);
p[3] = scheme_make_integer(sysTime.wDay);
p[4] = scheme_make_integer(sysTime.wMonth);
p[5] = scheme_make_integer(sysTime.wYear);
p[6] = scheme_make_integer(sysTime.wDayOfWeek);
p[7] = scheme_make_integer(yearDay);
p[8] = scheme_false;
p[9] = scheme_make_integer(0); // time zone offset
date_type = scheme_builtin_value("struct:date");
return scheme_make_struct_instance(date_type,sizeray(p),p);
}
static char *fieldNames[] = {
"second","minute","hour","day","month","year","week-day",
"year-day","dst?","time-zone-offset"
};
Scheme_Object *scheme_date_to_mx_date(int argc,Scheme_Object **argv) {
SYSTEMTIME sysTime;
DATE vDate;
Scheme_Object *date, *date_type;
int i;
date_type = scheme_builtin_value("struct:date");
if (scheme_is_struct_instance(date_type,argv[0]) == FALSE)
scheme_wrong_type("date->com-date","struct:date",0,argc,argv);
date = argv[0];
for (i = 0; i < 10; i++) {
// ignore DST boolean field
if (i != 8 && SCHEME_INTP(scheme_struct_ref(date,i)) == FALSE)
scheme_signal_error("date->com-date: date structure contains "
"non-fixnum in %s field",fieldNames[i]);
}
sysTime.wMilliseconds = 0;
sysTime.wSecond = (WORD)SCHEME_INT_VAL(scheme_struct_ref(date,0));
sysTime.wMinute = (WORD)SCHEME_INT_VAL(scheme_struct_ref(date,1));
sysTime.wHour = (WORD)SCHEME_INT_VAL(scheme_struct_ref(date,2));
sysTime.wDay = (WORD)SCHEME_INT_VAL(scheme_struct_ref(date,3));
sysTime.wMonth = (WORD)SCHEME_INT_VAL(scheme_struct_ref(date,4));
sysTime.wYear = (WORD)SCHEME_INT_VAL(scheme_struct_ref(date,5));
sysTime.wDayOfWeek = (WORD)SCHEME_INT_VAL(scheme_struct_ref(date,6));
if (SystemTimeToVariantTime(&sysTime,&vDate) == 0)
scheme_signal_error("date->com-date: unable to perform conversion");
return mx_make_date(&vDate);
}
SCODE mx_scode_val (Scheme_Object *obj)
{
return MX_SCODE_VAL (obj);
}
Scheme_Object * mx_scode_to_scheme_number (int argc, Scheme_Object **argv)
{
Scheme_Object *v;
v = GUARANTEE_SCODE ("com-scode->number", 0);
return scheme_make_integer_value (MX_SCODE_VAL (v));
}
Scheme_Object * scheme_number_to_mx_scode(int argc, Scheme_Object **argv)
{
intptr_t lv;
SCODE scode;
GUARANTEE_TYPE ("number->com-scode", 0, SCHEME_REALP, "number");
if (scheme_get_int_val (argv[0], &lv) == 0)
scheme_signal_error("number->com-scode: "
"number %V too big to fit in com-scode", argv[0]);
scode = lv;
return mx_make_scode (scode);
}
IDispatch * mx_comobj_val (Scheme_Object * obj)
{
return MX_COM_OBJ_VAL (obj);
}
IUnknown * mx_iunknown_val (Scheme_Object * obj)
{
return MX_IUNKNOWN_VAL (obj);
}
#endif // MYSTERX_3M

49
src/mysterx/gc-trav.rkt
View File

@ -1,49 +0,0 @@
#lang scheme/base
(printf "/* Generated from gc-trav.rkt */\n\n")
(define types
'([mx_com_object_type MX_COM_Object (types)]
[mx_com_type_type MX_COM_Type ()]
[mx_browser_type MX_Browser_Object ()]
[mx_document_type MX_Document_Object ()]
[mx_element_type MX_Element ()]
[mx_event_type MX_Event ()]
[mx_com_cy_type MX_COM_Data_Object ()]
[mx_com_date_type MX_COM_Data_Object ()]
[mx_com_scode_type MX_COM_Data_Object ()]
[mx_com_iunknown_type MX_COM_Data_Object ()]
[mx_com_omit_type MX_OMIT ()]
[mx_com_typedesc_type MX_TYPEDESC ()]
[mx_tbl_entry_type MX_TYPE_TBL_ENTRY (pTypeDesc next)]))
(for-each (lambda (type)
(let ([tag (car type)]
[ctype (cadr type)]
[ptr-fields (caddr type)])
(define (print-one prefix do-field)
(printf "static int ~a_~a(void *_p) {\n" prefix tag)
(when (and do-field
(pair? ptr-fields))
(printf " ~a *p = (~a *)_p;\n" ctype ctype)
(for-each (lambda (ptr-field)
(printf " ~a(p->~a);\n" do-field ptr-field))
ptr-fields))
(printf " return gcBYTES_TO_WORDS(sizeof(~a));\n" ctype)
(printf "}\n"))
(print-one "size" #f)
(print-one "mark" "gcMARK")
(print-one "fixup" "gcFIXUP")))
types)
(printf "\nstatic void register_traversers(void) {\n")
(for-each (lambda (type)
(let ([tag (car type)]
[ctype (cadr type)]
[ptr-fields (caddr type)])
(printf " GC_register_traversers(~a, size_~a, mark_~a, fixup_~a, 1, ~a);\n"
tag tag tag tag (if (null? ptr-fields) "1" "0"))))
types)
(printf "}\n")

290
src/mysterx/htmlevent.cxx
View File

@ -1,290 +0,0 @@
// event.cpp -- event-related functions
#ifdef MYSTERX_3M
// Created by xform.rkt:
# include "xsrc/htmlevent3m.cxx"
#else
#include "mysterx_pre.h"
#include <objbase.h>
#include <mshtml.h>
#include <initguid.h>
#include <winnls.h>
#include <exdisp.h>
#include "escheme.h"
#include "bstr.h"
#include "myspage.h"
#include "myssink.h"
#include "mysterx.h"
// number of elts should be same as in EVENT_TYPE enumeration
WCHAR *eventNames[11];
static BOOL html_event_available(MX_Browser_Object *browser) {
VARIANT_BOOL val;
val = 0;
browser->pIEventQueue->get_EventAvailable(&val);
return val;
}
static void html_event_sem_fun(MX_Browser_Object *browser,void *fds) {
scheme_add_fd_eventmask(fds,QS_ALLINPUT);
scheme_add_fd_handle(browser->readSem,fds,TRUE);
}
typedef int (*mzPOLL_PROC)(Scheme_Object *);
typedef void (*mzSLEEP_PROC)(Scheme_Object *,void *);
Scheme_Object *mx_block_until_event(int argc,Scheme_Object **argv) {
GUARANTEE_BROWSER ("block-until-event", 0);
scheme_block_until((mzPOLL_PROC)html_event_available,
(mzSLEEP_PROC)html_event_sem_fun,
argv[0],0.0F);
return scheme_void;
}
void initEventNames(void) {
eventNames[click] = L"click";
eventNames[dblclick] = L"dblclick";
eventNames[error] = L"error";
eventNames[keydown] = L"keydown";
eventNames[keypress] = L"keypress";
eventNames[keyup] = L"keyup";
eventNames[mousedown] = L"mousedown";
eventNames[mousemove] = L"mousemove";
eventNames[mouseout] = L"mouseout";
eventNames[mouseover] = L"mouseover";
eventNames[mouseup] = L"mouseup";
}
IEvent *getEventInterface(Scheme_Object *ev,char *fname) {
if (MX_EVENTP(ev) == FALSE) {
scheme_wrong_type(fname,"com-event",-1,0,&ev) ;
}
return MX_EVENT_VAL(ev);
}
Scheme_Object * mx_event_tag (int argc, Scheme_Object **argv)
{
BSTR tag;
IEvent *ev;
ev = getEventInterface(argv[0],"mx-event-tag");
ev->get_srcTag(&tag);
return unmarshalBSTR (tag);
}
Scheme_Object * mx_event_id (int argc, Scheme_Object **argv)
{
BSTR id;
IEvent *ev;
ev = getEventInterface(argv[0],"mx-event-id");
ev->get_srcId(&id);
return unmarshalBSTR (id);
}
Scheme_Object * mx_event_from_tag (int argc, Scheme_Object **argv)
{
BSTR tag;
IEvent *ev;
ev = getEventInterface(argv[0],"mx-event-from-tag");
ev->get_fromTag(&tag);
return unmarshalBSTR (tag);
}
Scheme_Object * mx_event_from_id (int argc, Scheme_Object **argv)
{
BSTR id;
IEvent *ev;
ev = getEventInterface (argv[0],"mx-event-from-id");
ev->get_fromId (&id);
return unmarshalBSTR (id);
}
Scheme_Object * mx_event_to_tag (int argc, Scheme_Object **argv)
{
BSTR tag;
IEvent *ev;
ev = getEventInterface (argv[0],"mx-event-to-tag");
ev->get_toTag (&tag);
return unmarshalBSTR (tag);
}
Scheme_Object * mx_event_to_id (int argc, Scheme_Object **argv)
{
BSTR id;
IEvent *ev;
ev = getEventInterface(argv[0],"mx-event-to-id");
ev->get_toId(&id);
return unmarshalBSTR (id);
}
Scheme_Object *mx_event_keycode(int argc,Scheme_Object **argv) {
long code;
IEvent *ev;
ev = getEventInterface(argv[0],"mx-event-keycode");
ev->get_keyCode(&code);
return scheme_make_integer(code);
}
Scheme_Object *mx_event_shiftkey(int argc,Scheme_Object **argv) {
VARIANT_BOOL vb;
IEvent *ev;
ev = getEventInterface(argv[0],"mx-event-shiftkey");
ev->get_shiftPressed(&vb);
return (vb == VARIANT_FALSE) ? scheme_false : scheme_true;
}
Scheme_Object *mx_event_altkey(int argc,Scheme_Object **argv) {
VARIANT_BOOL vb;
IEvent *ev;
ev = getEventInterface(argv[0],"mx-event-altkey");
ev->get_altPressed(&vb);
return (vb == VARIANT_FALSE) ? scheme_false : scheme_true;
}
Scheme_Object *mx_event_ctrlkey(int argc,Scheme_Object **argv) {
VARIANT_BOOL vb;
IEvent *ev;
ev = getEventInterface(argv[0],"mx-event-ctrlkey");
ev->get_ctrlPressed(&vb);
return (vb == VARIANT_FALSE) ? scheme_false : scheme_true;
}
Scheme_Object *mx_event_x(int argc,Scheme_Object **argv) {
long x;
IEvent *ev;
ev = getEventInterface(argv[0],"mx-event-x");
ev->get_x(&x);
return scheme_make_integer(x);
}
Scheme_Object *mx_event_y(int argc,Scheme_Object **argv) {
long y;
IEvent *ev;
ev = getEventInterface(argv[0],"mx-event-y");
ev->get_y(&y);
return scheme_make_integer(y);
}
Scheme_Object *mx_event_type_pred(int argc,Scheme_Object **argv,WCHAR *evType) {
EVENT_TYPE actualType;
IEvent *ev;
ev = getEventInterface(argv[0],"event-<event-type>?");
ev->get_eventType(&actualType);
return (wcscmp(evType,eventNames[actualType]) == 0)
? scheme_true
: scheme_false;
}
Scheme_Object *mx_event_pred(int argc,Scheme_Object **argv) {
return MX_EVENTP(argv[0]) ? scheme_true : scheme_false;
}
Scheme_Object *mx_event_keypress_pred(int argc,Scheme_Object **argv) {
return mx_event_type_pred(argc,argv,L"keypress");
}
Scheme_Object *mx_event_keydown_pred(int argc,Scheme_Object **argv) {
return mx_event_type_pred(argc,argv,L"keydown");
}
Scheme_Object *mx_event_keyup_pred(int argc,Scheme_Object **argv) {
return mx_event_type_pred(argc,argv,L"keyup");
}
Scheme_Object *mx_event_mousedown_pred(int argc,Scheme_Object **argv) {
return mx_event_type_pred(argc,argv,L"mousedown");
}
Scheme_Object *mx_event_mouseover_pred(int argc,Scheme_Object **argv) {
return mx_event_type_pred(argc,argv,L"mouseover");
}
Scheme_Object *mx_event_mousemove_pred(int argc,Scheme_Object **argv) {
return mx_event_type_pred(argc,argv,L"mousemove");
}
Scheme_Object *mx_event_mouseout_pred(int argc,Scheme_Object **argv) {
return mx_event_type_pred(argc,argv,L"mouseout");
}
Scheme_Object *mx_event_mouseup_pred(int argc,Scheme_Object **argv) {
return mx_event_type_pred(argc,argv,L"mouseup");
}
Scheme_Object *mx_event_click_pred(int argc,Scheme_Object **argv) {
return mx_event_type_pred(argc,argv,L"click");
}
Scheme_Object *mx_event_dblclick_pred(int argc,Scheme_Object **argv) {
return mx_event_type_pred(argc,argv,L"dblclick");
}
Scheme_Object *mx_event_error_pred(int argc,Scheme_Object **argv) {
return mx_event_type_pred(argc,argv,L"error");
}
Scheme_Object *mx_get_event(int argc,Scheme_Object **argv) {
HRESULT hr;
IEvent *pEvent;
IEventQueue *pEventQueue;
MX_Event *event_object;
pEventQueue = MX_BROWSER_EVENTQUEUE (GUARANTEE_BROWSER ("mx-get-event", 0));
pEvent = NULL; // DCOM requires this for some reason
hr = pEventQueue->GetEvent(&pEvent); // blocking call
if (hr != S_OK || pEvent == NULL) {
codedComError("Error retrieving event",hr);
}
event_object = (MX_Event *)scheme_malloc_tagged(sizeof(MX_Event));
event_object->so.type = mx_event_type;
event_object->released = FALSE;
event_object->pEvent = pEvent;
mx_register_simple_com_object((Scheme_Object *)event_object,pEvent);
return (Scheme_Object *)event_object;
}
#endif //MYSTERX_3M

1377
src/mysterx/htmlutil.cxx
View File

File diff suppressed because it is too large Load Diff

10
src/mysterx/mxmain.def
View File

@ -1,10 +0,0 @@
; mysterx.def : declares the module parameters
LIBRARY "mxmain.DLL"
EXPORTS
DllMain PRIVATE
scheme_reload PRIVATE
scheme_initialize PRIVATE
scheme_initialize_internal PRIVATE
scheme_module_name PRIVATE

BIN
src/mysterx/myspage/dhtmlpag.bmp
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 246 B

318
src/mysterx/myspage/dhtmlpage.cxx
View File

@ -1,318 +0,0 @@
// dhtmlpage.cxx : Implementation of CDHTMLPage
#include "stdafx.h"
#include "myspage.h"
#include "wrapper.h"
#include "dhtmlpage.h"
EVENT_MAP eventMap[11] = {
L"click",click,
L"dblclick",dblclick,
L"error",error,
L"keydown",keydown,
L"keypress",keypress,
L"keyup",keyup,
L"mousedown",mousedown,
L"mousemove",mousemove,
L"mouseout",mouseout,
L"mouseover",mouseover,
L"mouseup",mouseup,
};
/////////////////////////////////////////////////////////////////////////////
// CDHTMLPage
void ::failureBox (const char *s)
{
::MessageBox (NULL, s, "MysterX error", MB_OK);
}
static
int eventSearchCmp (const void *s1, const void *s2)
{
return wcscmp ((const WCHAR *)s1, ((const EVENT_MAP *)s2)->name);
}
HRESULT CDHTMLPage::SuppressCtxMenu (IDispatch *pDocDispatch)
{
HRESULT hr;
CComObject<CWrapperUIHandler> *pUIHandlerWrapper;
IDispatch *pContDisp;
ICustomDoc *pCustomDoc;
IDocHostUIHandler *pUIHandler;
// setup custom UI handler to block context menu
hr = ((IWebBrowser2 *)(m_spBrowser))->get_Container (&pContDisp);
if (hr != S_OK || pContDisp == NULL) {
::failureBox ("Can't get container from browser");
return S_OK;
}
hr = pContDisp->QueryInterface (IID_IDocHostUIHandler,
(void **)&pUIHandler);
if (hr != S_OK || pUIHandler == NULL) {
::failureBox ("Can't get UI handler from browser container");
return S_OK;
}
hr = pDocDispatch->QueryInterface (IID_ICustomDoc, (void **)&pCustomDoc);
if (hr != FALSE || pCustomDoc == NULL) {
::failureBox ("Can't get custom document from document");
return S_OK;
}
hr = pUIHandlerWrapper->CreateInstance (&pUIHandlerWrapper);
if (hr != FALSE) {
::failureBox ("Can't create UI wrapper for DHTML control");
return S_OK;
}
pUIHandlerWrapper->SetUIHandler (pUIHandler); // never fails
hr = pCustomDoc->SetUIHandler (pUIHandlerWrapper);
if (hr != S_OK) {
::failureBox ("Can't set UI handler for DHTML control");
return S_OK;
}
return S_OK;
}
HRESULT CDHTMLPage::AtAnyEvent (void)
{
HRESULT hr;
IHTMLEventObj *pIHTMLEventObj;
IEvent *pEvent;
EVENT_MAP *eventEntry;
BSTR eventString;
BSTR eltName;
BSTR idAttr;
IHTMLElement *pSrcElement,*pFromElement,*pToElement;
VARIANT variant;
VARIANT_BOOL altPressed;
VARIANT_BOOL ctrlPressed;
VARIANT_BOOL shiftPressed;
long mouseButton;
long x,y;
if (pTopWindow == NULL) {
IDispatch *pDocDispatch;
IHTMLWindow2 *pIHTMLWindow2;
IHTMLDocument2 *pIHTMLDocument2;
((IWebBrowser2 *)(m_spBrowser))->get_Document (&pDocDispatch);
if (pDocDispatch == NULL) {
::failureBox ("Can't get document on event trap");
return S_OK;
}
SuppressCtxMenu (pDocDispatch);
pDocDispatch->QueryInterface (IID_IHTMLDocument2, (void **)&pIHTMLDocument2);
pIHTMLDocument2->get_parentWindow (&pIHTMLWindow2);
if (pIHTMLWindow2 == NULL) {
::failureBox ("Can't get window on event trap");
return S_OK;
}
pIHTMLWindow2->get_top (&pTopWindow);
if (pTopWindow == NULL) {
::failureBox ("Can't get top window on event trap");
return S_OK;
}
}
pTopWindow->get_event (&pIHTMLEventObj);
if (pIHTMLEventObj == NULL) { // occurs on Refresh
pTopWindow = NULL;
return S_OK;
}
pEvent = NULL;
hr = CoCreateInstance (CLSID_Event, NULL, CLSCTX_ALL, IID_IEvent, (void **)&pEvent);
if (SUCCEEDED (hr) == FALSE || pEvent == NULL) {
::failureBox ("Can't create event in MysPage");
return -1;
}
pIHTMLEventObj->get_type (&eventString);
eventEntry = (EVENT_MAP *)bsearch (eventString, eventMap,
sizeray (eventMap), sizeof (*eventMap),
eventSearchCmp);
if (eventEntry == NULL)
return S_OK;
pEvent->put_eventType (eventEntry->eventType);
pIHTMLEventObj->get_x (&x);
pEvent->put_x (x);
pIHTMLEventObj->get_y (&y);
pEvent->put_y (y);
idAttr = SysAllocString (L"id");
pIHTMLEventObj->get_srcElement (&pSrcElement);
if (pSrcElement) {
pSrcElement->get_tagName (&eltName);
pEvent->put_srcTag (eltName);
pSrcElement->getAttribute (idAttr,FALSE,&variant);
if (variant.vt == VT_BSTR)
pEvent->put_srcId (variant.bstrVal);
pSrcElement->Release();
}
pIHTMLEventObj->get_altKey (&altPressed);
pEvent->put_altPressed (altPressed);
pIHTMLEventObj->get_ctrlKey (&ctrlPressed);
pEvent->put_ctrlPressed (ctrlPressed);
pIHTMLEventObj->get_shiftKey (&shiftPressed);
pEvent->put_shiftPressed (shiftPressed);
pIHTMLEventObj->get_button (&mouseButton);
pEvent->put_mouseButton ((MOUSE_BUTTON)mouseButton);
if (eventEntry->eventType == mouseover ||
eventEntry->eventType == mouseout) {
pIHTMLEventObj->get_fromElement (&pFromElement);
if (pFromElement) {
pFromElement->get_tagName (&eltName);
pEvent->put_fromTag (eltName);
pFromElement->getAttribute (idAttr,FALSE,&variant);
if (variant.vt == VT_BSTR)
pEvent->put_fromId (variant.bstrVal);
pFromElement->Release();
}
pIHTMLEventObj->get_toElement (&pToElement);
if (pToElement) {
pToElement->get_tagName (&eltName);
pEvent->put_toTag (eltName);
pToElement->getAttribute (idAttr,FALSE,&variant);
if (variant.vt == VT_BSTR)
pEvent->put_toId (variant.bstrVal);
pToElement->Release();
}
}
else if (eventEntry->eventType == keydown ||
eventEntry->eventType == keypress ||
eventEntry->eventType == keyup) {
long keycode;
pIHTMLEventObj->get_keyCode (&keycode);
pEvent->put_keyCode (keycode);
}
SysFreeString (idAttr);
pIEventQueue->QueueEvent (pEvent);
pIHTMLEventObj->Release();
return S_OK;
}
LRESULT CDHTMLPage::OnCreate (UINT, WPARAM, LPARAM, BOOL&)
{
CAxWindow wnd (m_hWnd);
CComObject<CWrapperDispatch> *pdispWrapper;
HRESULT hr;
// low bit set in parent's window style means use scrollbars
if (::GetWindowLong (::GetParent (m_hWnd), GWL_STYLE) & 1L)
wnd.ModifyStyle (0, WS_HSCROLL|WS_VSCROLL, 0);
hr = wnd.CreateControl (IDH_DHTMLPAGE);
if (SUCCEEDED (hr) == FALSE) {
::failureBox ("Can't create DHTML control");
return -1;
}
// Create a wrapper about the external dispatch interface
// workaround for IE5
hr = pdispWrapper->CreateInstance (&pdispWrapper);
if (SUCCEEDED (hr) == FALSE) {
::failureBox ("Can't create dispatch wrapper for DHTML control");
return -1;
}
CComPtr<IDHTMLPageUI> pdispExternal = com_cast<IDHTMLPageUI> (GetUnknown());
if (pdispExternal == NULL)
return E_UNEXPECTED;
pdispWrapper->SetDispatch (pdispExternal);
hr = wnd.SetExternalDispatch (pdispWrapper);
if (SUCCEEDED (hr) == FALSE) {
::failureBox ("Can't set dispatcher for DHTML control");
return -1;
}
hr = wnd.QueryControl (IID_IWebBrowser2, (void**)&m_spBrowser);
if (SUCCEEDED (hr) == FALSE) {
::failureBox ("Can't find browser in DHTML control");
return -1;
}
hr = CoCreateInstance (CLSID_EventQueue, NULL, CLSCTX_ALL,
IID_IEventQueue, (void **)&pIEventQueue);
if (SUCCEEDED (hr) == FALSE || pIEventQueue == NULL) {
::failureBox ("Can't create event queue");
return -1;
}
return 0;
}
STDMETHODIMP CDHTMLPage::marshalWebBrowserToStream (IStream **ppIStream)
{
HRESULT hr = CoMarshalInterThreadInterfaceInStream (IID_IWebBrowser2, m_spBrowser, ppIStream);
if (hr != S_OK)
failureBox ("Can't marshall Web browser");
return hr;
}
STDMETHODIMP CDHTMLPage::marshalEventQueueToStream (IStream **ppIStream)
{
HRESULT hr = CoMarshalInterThreadInterfaceInStream (IID_IEventQueue, pIEventQueue, ppIStream);
if (hr != S_OK)
failureBox ("Can't marshall event queue");
return hr;
}

118
src/mysterx/myspage/dhtmlpage.h
View File

@ -1,118 +0,0 @@
// DHTMLPage.h : Declaration of the CDHTMLPage
#ifndef __DHTMLPAGE_H_
#define __DHTMLPAGE_H_
#define _ATL_NO_DOCHOSTUIHANDLER
#include "resource.h" // main symbols
#include <atlctl.h>
#include <stdio.h>
#include <stdlib.h>
#include <mshtml.h>
#define sizeray(a) (sizeof(a)/sizeof(*a))
void failureBox(const char *s);
typedef struct _event_map_ {
WCHAR *name;
EVENT_TYPE eventType;
} EVENT_MAP;
extern EVENT_MAP eventMap[11];
/////////////////////////////////////////////////////////////////////////////
// CDHTMLPage
class ATL_NO_VTABLE CDHTMLPage :
public CComObjectRootEx<CComSingleThreadModel>,
public IDispatchImpl<IDHTMLPage, &IID_IDHTMLPage, &LIBID_MYSPAGELib>,
public IDispatchImpl<IDHTMLPageUI, &IID_IDHTMLPageUI, &LIBID_MYSPAGELib>,
public CComControl<CDHTMLPage>,
public IPersistStreamInitImpl<CDHTMLPage>,
public IOleControlImpl<CDHTMLPage>,
public IOleObjectImpl<CDHTMLPage>,
public IOleInPlaceActiveObjectImpl<CDHTMLPage>,
public IViewObjectExImpl<CDHTMLPage>,
public IOleInPlaceObjectWindowlessImpl<CDHTMLPage>,
public IPersistStorageImpl<CDHTMLPage>,
public ISpecifyPropertyPagesImpl<CDHTMLPage>,
public IQuickActivateImpl<CDHTMLPage>,
public IDataObjectImpl<CDHTMLPage>,
public IProvideClassInfo2Impl<&CLSID_DHTMLPage, NULL, &LIBID_MYSPAGELib>,
public CComCoClass<CDHTMLPage, &CLSID_DHTMLPage>
{
private:
IHTMLWindow2 *pTopWindow;
public:
CDHTMLPage()
{
m_bWindowOnly = TRUE;
pTopWindow = NULL;
}
DECLARE_REGISTRY_RESOURCEID(IDR_DHTMLPAGE)
DECLARE_PROTECT_FINAL_CONSTRUCT()
BEGIN_COM_MAP(CDHTMLPage)
COM_INTERFACE_ENTRY(IDHTMLPage)
COM_INTERFACE_ENTRY(IDHTMLPageUI)
COM_INTERFACE_ENTRY2(IDispatch, IDHTMLPage)
COM_INTERFACE_ENTRY(IViewObjectEx)
COM_INTERFACE_ENTRY(IViewObject2)
COM_INTERFACE_ENTRY(IViewObject)
COM_INTERFACE_ENTRY(IOleInPlaceObjectWindowless)
COM_INTERFACE_ENTRY(IOleInPlaceObject)
COM_INTERFACE_ENTRY2(IOleWindow, IOleInPlaceObjectWindowless)
COM_INTERFACE_ENTRY(IOleInPlaceActiveObject)
COM_INTERFACE_ENTRY(IOleControl)
COM_INTERFACE_ENTRY(IOleObject)
COM_INTERFACE_ENTRY(IPersistStreamInit)
COM_INTERFACE_ENTRY2(IPersist, IPersistStreamInit)
COM_INTERFACE_ENTRY(ISpecifyPropertyPages)
COM_INTERFACE_ENTRY(IQuickActivate)
COM_INTERFACE_ENTRY(IPersistStorage)
COM_INTERFACE_ENTRY(IDataObject)
COM_INTERFACE_ENTRY(IProvideClassInfo)
COM_INTERFACE_ENTRY(IProvideClassInfo2)
END_COM_MAP()
BEGIN_PROP_MAP(CDHTMLPage)
PROP_DATA_ENTRY("_cx", m_sizeExtent.cx, VT_UI4)
PROP_DATA_ENTRY("_cy", m_sizeExtent.cy, VT_UI4)
// Example entries
// PROP_ENTRY("Property Description", dispid, clsid)
// PROP_PAGE(CLSID_StockColorPage)
END_PROP_MAP()
BEGIN_MSG_MAP(CDHTMLPage)
MESSAGE_HANDLER(WM_CREATE, OnCreate)
CHAIN_MSG_MAP(CComControl<CDHTMLPage>)
END_MSG_MAP()
// Handler prototypes:
// LRESULT MessageHandler(UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled);
// LRESULT CommandHandler(WORD wNotifyCode, WORD wID, HWND hWndCtl, BOOL& bHandled);
// LRESULT NotifyHandler(int idCtrl, LPNMHDR pnmh, BOOL& bHandled);
// IViewObjectEx
DECLARE_VIEW_STATUS(0)
// IDHTMLPage
public:
// IDHTMLPageUI
public:
STDMETHOD(marshalEventQueueToStream)(IStream **);
STDMETHOD(marshalWebBrowserToStream)(IStream **);
CComPtr<IWebBrowser2> m_spBrowser;
IEventQueue *pIEventQueue;
LRESULT OnCreate(UINT,WPARAM,LPARAM,BOOL&);
STDMETHOD(AtAnyEvent)(void);
STDMETHOD(SuppressCtxMenu)(IDispatch *);
};
#endif //__DHTMLPAGE_H_

34
src/mysterx/myspage/dhtmlpage.rgs
View File

@ -1,34 +0,0 @@
HKCR
{
myspage.DHTMLPage.1 = s 'DHTMLPage Class'
{
CLSID = s '{0E7D148D-8948-11D2-B54E-0060089002FE}'
}
myspage.DHTMLPage = s 'DHTMLPage Class'
{
CLSID = s '{0E7D148D-8948-11D2-B54E-0060089002FE}'
CurVer = s 'myspage.DHTMLPage.1'
}
NoRemove CLSID
{
ForceRemove {0E7D148D-8948-11D2-B54E-0060089002FE} = s 'DHTMLPage Class'
{
ProgID = s 'myspage.DHTMLPage.1'
VersionIndependentProgID = s 'myspage.DHTMLPage'
ForceRemove 'Programmable'
InprocServer32 = s '%MODULE%'
{
val ThreadingModel = s 'Apartment'
}
ForceRemove 'Control'
ForceRemove 'Insertable'
ForceRemove 'ToolboxBitmap32' = s '%MODULE%, 101'
'MiscStatus' = s '0'
{
'1' = s '131473'
}
'TypeLib' = s '{0E7D1480-8948-11D2-B54E-0060089002FE}'
'Version' = s '1.0'
}
}
}

15
src/mysterx/myspage/dhtmlpageui.htm
View File

@ -1,15 +0,0 @@
<HTML>
<BODY id="MysterX DHTML Body"
onkeypress="window.external.AtAnyEvent()"
onkeydown="window.external.AtAnyEvent()"
onkeyup="window.external.AtAnyEvent()"
onmouseover="window.external.AtAnyEvent()"
onmousemove="window.external.AtAnyEvent()"
onmouseout="window.external.AtAnyEvent()"
onclick="window.external.AtAnyEvent()"
ondblclick="window.external.AtAnyEvent()"
onmousedown="window.external.AtAnyEvent()"
onmouseup="window.external.AtAnyEvent()"
onerror="window.external.AtAnyEvent()">
</BODY>
</HTML>

231
src/mysterx/myspage/event.cxx
View File

@ -1,231 +0,0 @@
// Event.cxx : Implementation of CEvent
#include "stdafx.h"
#include "myspage.h"
#include "Event.h"
/////////////////////////////////////////////////////////////////////////////
// CEvent
CEvent::CEvent(void) {
srcIdName = NULL;
srcTagName = NULL;
fromIdName = NULL;
fromTagName = NULL;
toIdName = NULL;
toTagName = NULL;
}
STDMETHODIMP CEvent::get_eventType(EVENT_TYPE *pVal) {
*pVal = eventType;
return S_OK;
}
STDMETHODIMP CEvent::put_eventType(EVENT_TYPE newVal) {
eventType = newVal;
return S_OK;
}
STDMETHODIMP CEvent::get_srcTag(BSTR *pVal) {
*pVal = srcTagName;
return S_OK;
}
STDMETHODIMP CEvent::put_srcTag(BSTR newVal) {
if (srcTagName) {
SysFreeString(srcTagName);
}
srcTagName = SysAllocString(newVal);
return S_OK;
}
STDMETHODIMP CEvent::get_srcId(BSTR *pVal)
{
*pVal = srcIdName;
return S_OK;
}
STDMETHODIMP CEvent::put_srcId(BSTR newVal)
{
if (srcIdName) {
SysFreeString(srcTagName);
}
srcIdName = SysAllocString(newVal);
return S_OK;
}
STDMETHODIMP CEvent::get_fromTag(BSTR *pVal) {
*pVal = fromTagName;
return S_OK;
}
STDMETHODIMP CEvent::put_fromTag(BSTR newVal) {
if (fromTagName) {
SysFreeString(fromTagName);
}
fromTagName = SysAllocString(newVal);
return S_OK;
}
STDMETHODIMP CEvent::get_fromId(BSTR *pVal) {
*pVal = fromIdName;
return S_OK;
}
STDMETHODIMP CEvent::put_fromId(BSTR newVal) {
if (fromIdName) {
SysFreeString(fromIdName);
}
fromIdName = SysAllocString(newVal);
return S_OK;
}
STDMETHODIMP CEvent::get_toTag(BSTR *pVal) {
*pVal = toTagName;
return S_OK;
}
STDMETHODIMP CEvent::put_toTag(BSTR newVal) {
if (toTagName) {
SysFreeString(toTagName);
}
toTagName = SysAllocString(newVal);
return S_OK;
}
STDMETHODIMP CEvent::get_toId(BSTR *pVal) {
*pVal = toIdName;
return S_OK;
}
STDMETHODIMP CEvent::put_toId(BSTR newVal) {
if (toIdName) {
SysFreeString(toIdName);
}
toIdName = SysAllocString(newVal);
return S_OK;
}
STDMETHODIMP CEvent::get_keyCode(long *pVal) {
*pVal = keyCode;
return S_OK;
}
STDMETHODIMP CEvent::put_keyCode(long newVal) {
keyCode = newVal;
return S_OK;
}
STDMETHODIMP CEvent::get_altPressed(VARIANT_BOOL *pVal) {
*pVal = altPressed;
return S_OK;
}
STDMETHODIMP CEvent::put_altPressed(VARIANT_BOOL newVal) {
altPressed = newVal;
return S_OK;
}
STDMETHODIMP CEvent::get_ctrlPressed(VARIANT_BOOL *pVal) {
*pVal = ctrlPressed;
return S_OK;
}
STDMETHODIMP CEvent::put_ctrlPressed(VARIANT_BOOL newVal) {
ctrlPressed = newVal;
return S_OK;
}
STDMETHODIMP CEvent::get_shiftPressed(VARIANT_BOOL *pVal) {
*pVal = shiftPressed;
return S_OK;
}
STDMETHODIMP CEvent::put_shiftPressed(VARIANT_BOOL newVal) {
shiftPressed = newVal;
return S_OK;
}
STDMETHODIMP CEvent::get_mouseButton(MOUSE_BUTTON *pVal) {
*pVal = mouseButton;
return S_OK;
}
STDMETHODIMP CEvent::put_mouseButton(MOUSE_BUTTON newVal) {
mouseButton = newVal;
return S_OK;
}
STDMETHODIMP CEvent::get_x(long *pVal) {
*pVal = x;
return S_OK;
}
STDMETHODIMP CEvent::put_x(long newVal) {
x = newVal;
return S_OK;
}
STDMETHODIMP CEvent::get_y(long *pVal) {
*pVal = y;
return S_OK;
}
STDMETHODIMP CEvent::put_y(long newVal) {
y = newVal;
return S_OK;
}

71
src/mysterx/myspage/event.h
View File

@ -1,71 +0,0 @@
// Event.h : Declaration of the CEvent
#ifndef __EVENT_H_
#define __EVENT_H_
#include "resource.h" // main symbols
/////////////////////////////////////////////////////////////////////////////
// CEvent
class ATL_NO_VTABLE CEvent :
public CComObjectRootEx<CComSingleThreadModel>,
public CComCoClass<CEvent, &CLSID_Event>,
public IDispatchImpl<IEvent, &IID_IEvent, &LIBID_MYSPAGELib>
{
private:
EVENT_TYPE eventType;
BSTR srcIdName,srcTagName;
BSTR fromIdName,fromTagName;
BSTR toIdName,toTagName;
VARIANT_BOOL altPressed,ctrlPressed,shiftPressed;
MOUSE_BUTTON mouseButton;
long keyCode;
long x,y;
public:
CEvent(void);
DECLARE_REGISTRY_RESOURCEID(IDR_EVENT)
DECLARE_PROTECT_FINAL_CONSTRUCT()
BEGIN_COM_MAP(CEvent)
COM_INTERFACE_ENTRY(IEvent)
COM_INTERFACE_ENTRY(IDispatch)
END_COM_MAP()
// IEvent
public:
STDMETHOD(get_y)(/*[out, retval]*/ long *pVal);
STDMETHOD(put_y)(/*[in]*/ long newVal);
STDMETHOD(get_x)(/*[out, retval]*/ long *pVal);
STDMETHOD(put_x)(/*[in]*/ long newVal);
STDMETHOD(get_mouseButton)(/*[out, retval]*/ MOUSE_BUTTON *pVal);
STDMETHOD(put_mouseButton)(/*[in]*/ MOUSE_BUTTON newVal);
STDMETHOD(get_keyCode)(/*[out, retval]*/ long *pVal);
STDMETHOD(put_keyCode)(/*[in]*/ long newVal);
STDMETHOD(get_shiftPressed)(/*[out, retval]*/ VARIANT_BOOL *pVal);
STDMETHOD(put_shiftPressed)(/*[in]*/ VARIANT_BOOL newVal);
STDMETHOD(get_ctrlPressed)(/*[out, retval]*/ VARIANT_BOOL *pVal);
STDMETHOD(put_ctrlPressed)(/*[in]*/ VARIANT_BOOL newVal);
STDMETHOD(get_altPressed)(/*[out, retval]*/ VARIANT_BOOL *pVal);
STDMETHOD(put_altPressed)(/*[in]*/ VARIANT_BOOL newVal);
STDMETHOD(get_toId)(/*[out, retval]*/ BSTR *pVal);
STDMETHOD(put_toId)(/*[in]*/ BSTR newVal);
STDMETHOD(get_toTag)(/*[out, retval]*/ BSTR *pVal);
STDMETHOD(put_toTag)(/*[in]*/ BSTR newVal);
STDMETHOD(get_fromId)(/*[out, retval]*/ BSTR *pVal);
STDMETHOD(put_fromId)(/*[in]*/ BSTR newVal);
STDMETHOD(get_fromTag)(/*[out, retval]*/ BSTR *pVal);
STDMETHOD(put_fromTag)(/*[in]*/ BSTR newVal);
STDMETHOD(get_srcId)(/*[out, retval]*/ BSTR *pVal);
STDMETHOD(put_srcId)(/*[in]*/ BSTR newVal);
STDMETHOD(get_srcTag)(/*[out, retval]*/BSTR *pVal);
STDMETHOD(put_srcTag)(/*[in]*/BSTR newVal);
STDMETHOD(get_eventType)(/*[out, retval]*/ EVENT_TYPE *pVal);
STDMETHOD(put_eventType)(/*[in]*/ EVENT_TYPE newVal);
};
#endif //__EVENT_H_

26
src/mysterx/myspage/event.rgs
View File

@ -1,26 +0,0 @@
HKCR
{
Myspage.Event.1 = s 'Event Class'
{
CLSID = s '{44D46F53-9375-11D2-B559-0060089002FE}'
}
Myspage.Event = s 'Event Class'
{
CLSID = s '{44D46F53-9375-11D2-B559-0060089002FE}'
CurVer = s 'Myspage.Event.1'
}
NoRemove CLSID
{
ForceRemove {44D46F53-9375-11D2-B559-0060089002FE} = s 'Event Class'
{
ProgID = s 'Myspage.Event.1'
VersionIndependentProgID = s 'Myspage.Event'
ForceRemove 'Programmable'
InprocServer32 = s '%MODULE%'
{
val ThreadingModel = s 'Apartment'
}
'TypeLib' = s '{0E7D1480-8948-11D2-B54E-0060089002FE}'
}
}
}

110
src/mysterx/myspage/eventqueue.cxx
View File

@ -1,110 +0,0 @@
// eventqueue.cxx : Implementation of CEventQueue
#include "stdafx.h"
#include <stdio.h>
#include <limits.h>
#include <stdarg.h>
#include "escheme.h"
#include "myspage.h"
#include "dhtmlpage.h"
#include "eventqueue.h"
/////////////////////////////////////////////////////////////////////////////
// CEventQueue
CEventQueue::CEventQueue (void)
{
queueLength = 0;
readerNdx = writerNdx = 0;
readSem = CreateSemaphore (NULL, 0, LONG_MAX, NULL); // using MAXQUEUELENGTH doesn't work
mutex = CreateSemaphore (NULL, 1, 1, NULL);
if (readSem == NULL || mutex == NULL)
::failureBox ("Error creating event semaphore(s)");
}
CEventQueue::~CEventQueue (void)
{
if (readSem != NULL)
CloseHandle (readSem);
if (mutex != NULL)
CloseHandle (mutex);
}
STDMETHODIMP CEventQueue::QueueEvent (IEvent *pEvent)
{
BOOL signalReader;
WaitForSingleObject (mutex, INFINITE);
if (queueLength < MAXQUEUELENGTH) {
queueLength++;
signalReader = TRUE;
}
else {
readerNdx = ++readerNdx % MAXQUEUELENGTH;
signalReader = FALSE;
}
theQueue[writerNdx] = pEvent;
writerNdx = ++writerNdx % MAXQUEUELENGTH;
ReleaseSemaphore (mutex, 1, NULL);
if (signalReader)
ReleaseSemaphore (readSem, 1, NULL);
return S_OK;
}
STDMETHODIMP CEventQueue::GetEvent (IEvent **ppEvent)
{
*ppEvent = NULL;
WaitForSingleObject (readSem, INFINITE);
WaitForSingleObject (mutex, INFINITE);
*ppEvent = theQueue[readerNdx];
readerNdx = ++readerNdx % MAXQUEUELENGTH;
queueLength--;
ReleaseSemaphore (mutex, 1, NULL);
return S_OK;
}
STDMETHODIMP CEventQueue::get_EventAvailable (VARIANT_BOOL *pVal)
{
WaitForSingleObject (mutex, INFINITE);
*pVal = (queueLength == 0) ? 0 : -1;
ReleaseSemaphore (mutex, 1, NULL);
return S_OK;
}
STDMETHODIMP CEventQueue::GetReaderSemaphore (long * pReadSem)
{
* ((HANDLE *)pReadSem) = readSem;
return S_OK;
}
// This method is deprecated. It is still here so that older
// code won't break.
STDMETHODIMP CEventQueue::set_extension_table (int)
{
/* scheme_extension_table = (Scheme_Extension_Table *)p; */
return S_OK;
}

50
src/mysterx/myspage/eventqueue.h
View File

@ -1,50 +0,0 @@
// EventQueue.h : Declaration of the CEventQueue
#ifndef __EVENTQUEUE_H_
#define __EVENTQUEUE_H_
#include "resource.h" // main symbols
#define MAXQUEUELENGTH 8192
void failureBox(const char *s);
/////////////////////////////////////////////////////////////////////////////
// CEventQueue
class ATL_NO_VTABLE CEventQueue :
public CComObjectRootEx<CComSingleThreadModel>,
public CComCoClass<CEventQueue, &CLSID_EventQueue>,
public IDispatchImpl<IEventQueue, &IID_IEventQueue, &LIBID_MYSPAGELib>
{
private:
HANDLE readSem,mutex;
int readerNdx,writerNdx;
int queueLength;
IEvent *theQueue[MAXQUEUELENGTH];
void * xxxscheme_extension_table;
public:
CEventQueue(void);
~CEventQueue(void);
DECLARE_REGISTRY_RESOURCEID(IDR_EVENTQUEUE)
DECLARE_PROTECT_FINAL_CONSTRUCT()
BEGIN_COM_MAP(CEventQueue)
COM_INTERFACE_ENTRY(IEventQueue)
COM_INTERFACE_ENTRY(IDispatch)
END_COM_MAP()
// IEventQueue
public:
STDMETHOD(get_EventAvailable)(VARIANT_BOOL *pVal);
STDMETHOD(QueueEvent)(IEvent *pEvent);
STDMETHOD(GetEvent)(IEvent **ppEvent);
STDMETHOD(GetReaderSemaphore)(long *);
// THIS METHOD IS DEPRECATED
STDMETHOD(set_extension_table)(int);
};
#endif //__EVENTQUEUE_H_

26
src/mysterx/myspage/eventqueue.rgs
View File

@ -1,26 +0,0 @@
HKCR
{
Myspage.EventQueue.1 = s 'EventQueue Class'
{
CLSID = s '{44D46F51-9375-11D2-B559-0060089002FE}'
}
Myspage.EventQueue = s 'EventQueue Class'
{
CLSID = s '{44D46F51-9375-11D2-B559-0060089002FE}'
CurVer = s 'Myspage.EventQueue.1'
}
NoRemove CLSID
{
ForceRemove {44D46F51-9375-11D2-B559-0060089002FE} = s 'EventQueue Class'
{
ProgID = s 'Myspage.EventQueue.1'
VersionIndependentProgID = s 'Myspage.EventQueue'
ForceRemove 'Programmable'
InprocServer32 = s '%MODULE%'
{
val ThreadingModel = s 'Apartment'
}
'TypeLib' = s '{0E7D1480-8948-11D2-B54E-0060089002FE}'
}
}
}

78
src/mysterx/myspage/myspage.cxx
View File

@ -1,78 +0,0 @@
// myspage.cxx : Implementation of DLL Exports.
// Note: Proxy/Stub Information
// To build a separate proxy/stub DLL,
// run nmake -f myspageps.mk in the project directory.
#include "stdafx.h"
#include "resource.h"
#include <initguid.h>
#include "escheme.h"
#include "myspage.h"
#include "myspage_i.c"
#include "DHTMLPage.h"
#include "Event.h"
#include "EventQueue.h"
CComModule _Module;
BEGIN_OBJECT_MAP(ObjectMap)
OBJECT_ENTRY(CLSID_DHTMLPage, CDHTMLPage)
OBJECT_ENTRY(CLSID_Event, CEvent)
OBJECT_ENTRY(CLSID_EventQueue, CEventQueue)
END_OBJECT_MAP()
/////////////////////////////////////////////////////////////////////////////
// DLL Entry Point
extern "C"
BOOL WINAPI DllMain(HINSTANCE hInstance, DWORD dwReason, LPVOID /*lpReserved*/)
{
if (dwReason == DLL_PROCESS_ATTACH)
{
_Module.Init(ObjectMap, hInstance, &LIBID_MYSPAGELib);
DisableThreadLibraryCalls(hInstance);
}
else if (dwReason == DLL_PROCESS_DETACH)
_Module.Term();
return TRUE; // ok
}
/////////////////////////////////////////////////////////////////////////////
// Used to determine whether the DLL can be unloaded by OLE
STDAPI DllCanUnloadNow(void)
{
return (_Module.GetLockCount()==0) ? S_OK : S_FALSE;
}
/////////////////////////////////////////////////////////////////////////////
// Returns a class factory to create an object of the requested type
STDAPI DllGetClassObject(REFCLSID rclsid, REFIID riid, LPVOID* ppv)
{
return _Module.GetClassObject(rclsid, riid, ppv);
}
/////////////////////////////////////////////////////////////////////////////
// DllRegisterServer - Adds entries to the system registry
STDAPI DllRegisterServer(void)
{
// registers object, typelib and all interfaces in typelib
return _Module.RegisterServer(TRUE);
}
/////////////////////////////////////////////////////////////////////////////
// DllUnregisterServer - Removes entries from the system registry
STDAPI DllUnregisterServer(void)
{
return _Module.UnregisterServer(TRUE);
}

9
src/mysterx/myspage/myspage.def
View File

@ -1,9 +0,0 @@
; myspage.def : Declares the module parameters.
LIBRARY "myspage.DLL"
EXPORTS
DllCanUnloadNow PRIVATE
DllGetClassObject PRIVATE
DllRegisterServer PRIVATE
DllUnregisterServer PRIVATE

142
src/mysterx/myspage/myspage.idl
View File

@ -1,142 +0,0 @@
// myspage.idl : IDL source for myspage.dll
//
// This file will be processed by the MIDL tool to
// produce the type library (myspage.tlb) and marshalling code.
import "oaidl.idl";
import "ocidl.idl";
#include "olectl.h"
typedef enum _event_type_ {
click,
dblclick,
error,
keydown,
keypress,
keyup,
mousedown,
mousemove,
mouseout,
mouseover,
mouseup
} EVENT_TYPE;
typedef enum _mouse_button_ {
none=0,left=1,middle=2,right=4 /* same as MS encoding */
} MOUSE_BUTTON;
[
object,
uuid(0E7D148C-8948-11D2-B54E-0060089002FE),
dual,
helpstring("IDHTMLPage Interface"),
pointer_default(unique)
]
interface IDHTMLPage : IDispatch
{
[id(1), helpstring("method marshalWebBrowserToStream")] HRESULT marshalWebBrowserToStream(IStream **);
[id(2), helpstring("method marshalEventQueueToStream")] HRESULT marshalEventQueueToStream(IStream **);
};
[
object,
uuid(0E7D148E-8948-11D2-B54E-0060089002FE),
dual,
helpstring("IDHTMLPageUI Interface"),
pointer_default(unique)
]
interface IDHTMLPageUI : IDispatch
{
HRESULT AtAnyEvent();
};
[
object,
uuid(FED3418C-9505-11D2-B55E-0060089002FE),
dual,
helpstring("IEvent Interface"),
pointer_default(unique)
]
interface IEvent : IDispatch
{
[propget, id(1), helpstring("property eventType")] HRESULT eventType([out, retval] EVENT_TYPE *pVal);
[propput, id(1), helpstring("property eventType")] HRESULT eventType([in] EVENT_TYPE newVal);
[propget, id(2), helpstring("property sourceElement")] HRESULT srcTag([out, retval] BSTR *);
[propput, id(2), helpstring("property sourceElement")] HRESULT srcTag([in] BSTR);
[propget, id(3), helpstring("property srcId")] HRESULT srcId([out, retval] BSTR *pVal);
[propput, id(3), helpstring("property srcId")] HRESULT srcId([in] BSTR newVal);
[propget, id(4), helpstring("property fromTag")] HRESULT fromTag([out, retval] BSTR *pVal);
[propput, id(4), helpstring("property fromTag")] HRESULT fromTag([in] BSTR newVal);
[propget, id(5), helpstring("property fromId")] HRESULT fromId([out, retval] BSTR *pVal);
[propput, id(5), helpstring("property fromId")] HRESULT fromId([in] BSTR newVal);
[propget, id(6), helpstring("property toTag")] HRESULT toTag([out, retval] BSTR *pVal);
[propput, id(6), helpstring("property toTag")] HRESULT toTag([in] BSTR newVal);
[propget, id(7), helpstring("property toId")] HRESULT toId([out, retval] BSTR *pVal);
[propput, id(7), helpstring("property toId")] HRESULT toId([in] BSTR newVal);
[propget, id(8), helpstring("property keyCode")] HRESULT keyCode([out, retval] long *pVal);
[propput, id(8), helpstring("property keyCode")] HRESULT keyCode([in] long newVal);
[propget, id(9), helpstring("property altPressed")] HRESULT altPressed([out, retval] VARIANT_BOOL *pVal);
[propput, id(9), helpstring("property altPressed")] HRESULT altPressed([in] VARIANT_BOOL newVal);
[propget, id(10), helpstring("property ctrlPressed")] HRESULT ctrlPressed([out, retval] VARIANT_BOOL *pVal);
[propput, id(10), helpstring("property ctrlPressed")] HRESULT ctrlPressed([in] VARIANT_BOOL newVal);
[propget, id(11), helpstring("property shiftPressed")] HRESULT shiftPressed([out, retval] VARIANT_BOOL *pVal);
[propput, id(11), helpstring("property shiftPressed")] HRESULT shiftPressed([in] VARIANT_BOOL newVal);
[propget, id(12), helpstring("property mouseButton")] HRESULT mouseButton([out, retval] MOUSE_BUTTON *pVal);
[propput, id(12), helpstring("property mouseButton")] HRESULT mouseButton([in] MOUSE_BUTTON newVal);
[propget, id(13), helpstring("property x")] HRESULT x([out, retval] long *pVal);
[propput, id(13), helpstring("property x")] HRESULT x([in] long newVal);
[propget, id(14), helpstring("property y")] HRESULT y([out, retval] long *pVal);
[propput, id(14), helpstring("property y")] HRESULT y([in] long newVal);
};
[
object,
uuid(FED3418D-9505-11D2-B55E-0060089002FE),
dual,
helpstring("IEventQueue Interface"),
pointer_default(unique)
]
interface IEventQueue : IDispatch
{
[id(1), helpstring("method GetEvent")] HRESULT GetEvent(IEvent **);
[id(2), helpstring("method QueueEvent")] HRESULT QueueEvent(IEvent *);
[id(3), helpstring("method GetReaderSemaphore")] HRESULT GetReaderSemaphore(long *);
[id(4), helpstring("method set_extension_table")] HRESULT set_extension_table(int);
[propget, id(5), helpstring("property EventAvailable")] HRESULT EventAvailable([out, retval] VARIANT_BOOL *pVal);
};
[
uuid(0E7D1480-8948-11D2-B54E-0060089002FE),
version(1.0),
helpstring("myspage 1.0 Type Library")
]
library MYSPAGELib
{
importlib("stdole32.tlb");
importlib("stdole2.tlb");
[
uuid(0E7D148D-8948-11D2-B54E-0060089002FE),
helpstring("DHTMLPage Class")
]
coclass DHTMLPage
{
[default] interface IDHTMLPage;
interface IDHTMLPageUI;
};
[
uuid(44D46F53-9375-11D2-B559-0060089002FE),
helpstring("Event Class")
]
coclass Event
{
[default] interface IEvent;
};
[
uuid(44D46F51-9375-11D2-B559-0060089002FE),
helpstring("EventQueue Class")
]
coclass EventQueue
{
[default] interface IEventQueue;
};
};

62
src/mysterx/myspage/myspage.mak
View File

@ -1,62 +0,0 @@
# myspage.mak
CPP=cl.exe
CPP_FLAGS=/I"$(SHELL32)/Include" /I"../../../include" /MT /W3 /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "_WINDLL" /D"MYSPAGE_EXPORTS" /D "_ATL_STATIC_REGISTRY" /D "_ATL_MIN_CRT" /c
.cxx.obj::
$(CPP) $(CPP_FLAGS) $<
MTL=midl.exe
MTL_SWITCHES=/tlb ".\myspage.tlb" /h "myspage.h" /iid "myspage_i.c" /Oicf
RSC=rc.exe
RSC_PROJ=/l 0x409 /fo"myspage.res"
LINK32=link.exe
LINK32_FLAGS=kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib "$(SHELL32)\Lib\shell32.lib" ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /dll /incremental:no /machine:I386 /def:myspage.def /out:myspage.dll
DEF_FILE= myspage.def
LINK32_OBJS= dhtmlpage.obj event.obj eventqueue.obj myspage.obj stdafx.obj \
myspage.res
all : myspage.tlb myspage.dll myspage.h myspage_i.c
myspage.dll : $(DEF_FILE) $(LINK32_OBJS)
$(LINK32) $(LINK32_FLAGS) $(LINK32_OBJS)
copy myspage.dll ..\..\..\collects\mysterx\private\compiled\native\win32\i386
$(REGSVR32) /s ..\..\..\collects\mysterx\private\compiled\native\win32\i386\myspage.dll
clean :
-@erase DHTMLPage.obj
-@erase Event.obj
-@erase EventQueue.obj
-@erase myspage.obj
-@erase myspage.res
-@erase StdAfx.obj
-@erase myspage.dll
-@erase myspage.exp
-@erase myspage.lib
-@erase myspage.h
-@erase myspage.tlb
-@erase myspage_i.c
-@erase myspage_p.c
.cxx{$(INTDIR)}.obj::
$(CPP) $(CPP_FLAGS) $<
dhtmlpage.obj : dhtmlpage.cxx dhtmlpage.h dhtmlpageui.htm wrapper.h stdafx.h
event.obj : event.cxx event.h stdafx.h
eventqueue.obj : eventqueue.cxx eventqueue.h stdafx.h
myspage.obj : myspage.cxx myspage.h dhtmlpage.h event.h eventqueue.h stdafx.h
stdafx.obj : stdafx.cxx stdafx.h
myspage.res : myspage.rc myspage.tlb
$(RSC) $(RSC_PROJ) myspage.rc
myspage.tlb myspage.h myspage_i.c : myspage.idl
$(MTL) $(MTL_SWITCHES) myspage.idl

140
src/mysterx/myspage/myspage.rc
View File

@ -1,140 +0,0 @@
//Microsoft Developer Studio generated resource script.
//
#include "resource.h"
#define APSTUDIO_READONLY_SYMBOLS
/////////////////////////////////////////////////////////////////////////////
//
// Generated from the TEXTINCLUDE 2 resource.
//
#include "winres.h"
/////////////////////////////////////////////////////////////////////////////
#undef APSTUDIO_READONLY_SYMBOLS
/////////////////////////////////////////////////////////////////////////////
// English (U.S.) resources
#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_ENU)
#ifdef _WIN32
LANGUAGE LANG_ENGLISH, SUBLANG_ENGLISH_US
#pragma code_page(1252)
#endif //_WIN32
#ifdef APSTUDIO_INVOKED
/////////////////////////////////////////////////////////////////////////////
//
// TEXTINCLUDE
//
1 TEXTINCLUDE DISCARDABLE
BEGIN
"resource.h\0"
END
2 TEXTINCLUDE DISCARDABLE
BEGIN
"#include ""winres.h""\r\n"
"\0"
END
3 TEXTINCLUDE DISCARDABLE
BEGIN
"1 TYPELIB ""myspage.tlb""\r\n"
"\0"
END
#endif // APSTUDIO_INVOKED
#ifndef _MAC
/////////////////////////////////////////////////////////////////////////////
//
// Version
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 1,0,0,1
PRODUCTVERSION 1,0,0,1
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
#else
FILEFLAGS 0x0L
#endif
FILEOS 0x4L
FILETYPE 0x2L
FILESUBTYPE 0x0L
BEGIN
BLOCK "StringFileInfo"
BEGIN
BLOCK "040904B0"
BEGIN
VALUE "CompanyName", "\0"
VALUE "FileDescription", "myspage Module\0"
VALUE "FileVersion", "1, 0, 0, 1\0"
VALUE "InternalName", "myspage\0"
VALUE "LegalCopyright", "Copyright 1999, Rice University PLT (Paul Steckler)\0"
VALUE "OriginalFilename", "myspage.DLL\0"
VALUE "ProductName", "myspage Module\0"
VALUE "ProductVersion", "1, 0, 0, 1\0"
VALUE "OLESelfRegister", "\0"
END
END
BLOCK "VarFileInfo"
BEGIN
VALUE "Translation", 0x409, 1200
END
END
#endif // !_MAC
/////////////////////////////////////////////////////////////////////////////
//
// Bitmap
//
IDB_DHTMLPAGE BITMAP DISCARDABLE "dhtmlpag.bmp"
/////////////////////////////////////////////////////////////////////////////
//
// HTML
//
IDH_DHTMLPAGE HTML DISCARDABLE "DHTMLPageUI.htm"
/////////////////////////////////////////////////////////////////////////////
//
// REGISTRY
//
IDR_DHTMLPAGE REGISTRY DISCARDABLE "DHTMLPage.rgs"
IDR_EVENT REGISTRY DISCARDABLE "Event.rgs"
IDR_EVENTQUEUE REGISTRY DISCARDABLE "EventQueue.rgs"
/////////////////////////////////////////////////////////////////////////////
//
// String Table
//
STRINGTABLE DISCARDABLE
BEGIN
IDS_PROJNAME "myspage"
END
#endif // English (U.S.) resources
/////////////////////////////////////////////////////////////////////////////
#ifndef APSTUDIO_INVOKED
/////////////////////////////////////////////////////////////////////////////
//
// Generated from the TEXTINCLUDE 3 resource.
//
1 TYPELIB "myspage.tlb"
/////////////////////////////////////////////////////////////////////////////
#endif // not APSTUDIO_INVOKED

21
src/mysterx/myspage/resource.h
View File

@ -1,21 +0,0 @@
//{{NO_DEPENDENCIES}}
// Microsoft Developer Studio generated include file.
// Used by myspage.rc
//
#define IDS_PROJNAME 100
#define IDB_DHTMLPAGE 101
#define IDH_DHTMLPAGE 102
#define IDR_DHTMLPAGE 103
#define IDR_EVENT 113
#define IDR_EVENTQUEUE 114
// Next default values for new objects
//
#ifdef APSTUDIO_INVOKED
#ifndef APSTUDIO_READONLY_SYMBOLS
#define _APS_NEXT_RESOURCE_VALUE 201
#define _APS_NEXT_COMMAND_VALUE 32768
#define _APS_NEXT_CONTROL_VALUE 201
#define _APS_NEXT_SYMED_VALUE 115
#endif
#endif

16
src/mysterx/myspage/stdafx.cxx
View File

@ -1,16 +0,0 @@
// stdafx.cpp : source file that includes just the standard includes
// stdafx.pch will be the pre-compiled header
// stdafx.obj will contain the pre-compiled type information
#include "stdafx.h"
/* OBSOLETE in vs.NET
#ifdef _ATL_STATIC_REGISTRY
#include <statreg.h>
#include <statreg.cpp>
#endif
#include <atlimpl.cpp>
*/

31
src/mysterx/myspage/stdafx.h
View File

@ -1,31 +0,0 @@
// stdafx.h : include file for standard system include files,
// or project specific include files that are used frequently,
// but are changed infrequently
#if !defined(AFX_STDAFX_H__0E7D1483_8948_11D2_B54E_0060089002FE__INCLUDED_)
#define AFX_STDAFX_H__0E7D1483_8948_11D2_B54E_0060089002FE__INCLUDED_
#if _MSC_VER > 1000
#pragma once
#endif // _MSC_VER > 1000
#define STRICT
#ifndef _WIN32_WINNT
#define _WIN32_WINNT 0x0400
#endif
#define _ATL_APARTMENT_THREADED
#include <atlbase.h>
//You may derive a class from CComModule and use it if you want to override
//something, but do not change the name of _Module
extern CComModule _Module;
#include <atlcom.h>
#include <atlhost.h>
#include <mshtml.h>
#include <exdisp.h>
#include <atlctl.h>
//{{AFX_INSERT_LOCATION}}
// Microsoft Visual C++ will insert additional declarations immediately before the previous line.
#endif // !defined(AFX_STDAFX_H__0E7D1483_8948_11D2_B54E_0060089002FE__INCLUDED)

209
src/mysterx/myspage/wrapper.h
View File

@ -1,209 +0,0 @@
#pragma once
#ifndef __WRAPPERS_H__
#define __WRAPPERS_H__
// based on Chris Sells' code at www.sellsbrothers.com/tools
class CWrapperDispatch :
public CComObjectRootEx<CComSingleThreadModel>,
public CComCoClass<CWrapperDispatch>,
public IDispatch
{
public:
void SetDispatch(IDispatch* pdisp) {
m_spdisp = pdisp;
}
DECLARE_NO_REGISTRY()
BEGIN_COM_MAP(CWrapperDispatch)
COM_INTERFACE_ENTRY(IDispatch)
END_COM_MAP()
// IDispatch
STDMETHODIMP GetTypeInfoCount (UINT* pctinfo)
{
return m_spdisp != NULL
? m_spdisp->GetTypeInfoCount (pctinfo)
: E_UNEXPECTED;
}
STDMETHODIMP GetTypeInfo (UINT itinfo, LCID lcid, ITypeInfo** pptinfo)
{
return pptinfo != NULL
? ((* pptinfo = 0, m_spdisp != NULL)
? m_spdisp->GetTypeInfo (itinfo, lcid, pptinfo)
: E_UNEXPECTED)
: E_POINTER;
}
STDMETHODIMP GetIDsOfNames (REFIID riid, LPOLESTR* rgszNames, UINT cNames,
LCID lcid, DISPID* rgdispid)
{
return m_spdisp != NULL
? m_spdisp->GetIDsOfNames (riid, rgszNames, cNames, lcid, rgdispid)
: E_UNEXPECTED;
}
STDMETHODIMP Invoke (DISPID dispidMember, REFIID riid, LCID lcid,
WORD wFlags, DISPPARAMS* pdispparams,
VARIANT* pvarResult, EXCEPINFO* pexcepinfo,
UINT* puArgErr)
{
return m_spdisp != NULL
? m_spdisp->Invoke (dispidMember, riid, lcid,
wFlags, pdispparams,
pvarResult, pexcepinfo,
puArgErr)
: E_UNEXPECTED;
}
private:
CComPtr<IDispatch> m_spdisp;
};
// this class override IDocHostUIHandler, to block context menus
class CWrapperUIHandler :
public CComObjectRootEx<CComSingleThreadModel>,
public CComCoClass<CWrapperUIHandler>,
public IDocHostUIHandler
{
public:
void SetUIHandler(IDocHostUIHandler* pHandler) {
m_spHandler = pHandler;
}
DECLARE_NO_REGISTRY()
BEGIN_COM_MAP(CWrapperUIHandler)
COM_INTERFACE_ENTRY(IDocHostUIHandler)
END_COM_MAP()
// IDocHostUIHandler
STDMETHODIMP ShowContextMenu (DWORD, POINT *,
IUnknown *,
IDispatch *)
{
return m_spHandler != NULL
? S_OK // overrides default menu
: E_UNEXPECTED;
}
STDMETHODIMP GetHostInfo (DOCHOSTUIINFO *pInfo)
{
return m_spHandler != NULL
? m_spHandler->GetHostInfo (pInfo)
: E_UNEXPECTED;
}
STDMETHODIMP ShowUI (DWORD dwID,
IOleInPlaceActiveObject *pActiveObject,
IOleCommandTarget *pCommandTarget,
IOleInPlaceFrame *pFrame,
IOleInPlaceUIWindow *pDoc)
{
return m_spHandler != NULL
? m_spHandler->ShowUI (dwID, pActiveObject,
pCommandTarget, pFrame, pDoc)
: E_UNEXPECTED;
}
STDMETHODIMP HideUI (void)
{
return m_spHandler != NULL
? m_spHandler->HideUI()
: E_UNEXPECTED;
}
STDMETHODIMP UpdateUI (void)
{
return m_spHandler != NULL
? m_spHandler->UpdateUI()
: E_UNEXPECTED;
}
STDMETHODIMP EnableModeless (BOOL fEnable)
{
return m_spHandler != NULL
? m_spHandler->EnableModeless (fEnable)
: E_UNEXPECTED;
}
STDMETHODIMP OnDocWindowActivate (BOOL fActivate)
{
return m_spHandler != NULL
? m_spHandler->OnDocWindowActivate (fActivate)
: E_UNEXPECTED;
}
STDMETHODIMP OnFrameWindowActivate (BOOL fActivate)
{
return m_spHandler != NULL
? m_spHandler->OnFrameWindowActivate (fActivate)
: E_UNEXPECTED;
}
STDMETHODIMP ResizeBorder (LPCRECT prcBorder,
IOleInPlaceUIWindow *pUIWindow, BOOL fFrameWindow)
{
return m_spHandler != NULL
? m_spHandler->ResizeBorder (prcBorder, pUIWindow, fFrameWindow)
: E_UNEXPECTED;
}
STDMETHODIMP TranslateAccelerator (LPMSG lpMsg,
const GUID __RPC_FAR *pguidCmdGroup,
DWORD nCmdID)
{
return m_spHandler != NULL
? m_spHandler->TranslateAccelerator (lpMsg, pguidCmdGroup, nCmdID)
: E_UNEXPECTED;
}
STDMETHODIMP GetOptionKeyPath (LPOLESTR *pchKey, DWORD dw)
{
return m_spHandler != NULL
? m_spHandler->GetOptionKeyPath (pchKey,dw)
: E_UNEXPECTED;
}
STDMETHODIMP GetDropTarget (IDropTarget *pDropTarget, IDropTarget **ppDropTarget)
{
return m_spHandler != NULL
? m_spHandler->GetDropTarget (pDropTarget, ppDropTarget)
: E_UNEXPECTED;
}
STDMETHODIMP GetExternal (IDispatch **ppDispatch)
{
return m_spHandler != NULL
? m_spHandler->GetExternal (ppDispatch)
: E_UNEXPECTED;
}
STDMETHODIMP TranslateUrl (DWORD dwTranslate,
OLECHAR *pchURLIn,
OLECHAR **ppchURLOut)
{
return m_spHandler != NULL
? m_spHandler->TranslateUrl (dwTranslate, pchURLIn, ppchURLOut)
: E_UNEXPECTED;
}
STDMETHODIMP FilterDataObject (IDataObject *pDO,
IDataObject **ppDORet)
{
return m_spHandler != NULL
? m_spHandler->FilterDataObject (pDO,ppDORet)
: E_UNEXPECTED;
}
private:
CComPtr<IDocHostUIHandler> m_spHandler;
};
#endif // __WRAPPERS_H__

5573
src/mysterx/mysterx.cxx
View File

File diff suppressed because it is too large Load Diff

905
src/mysterx/mysterx.h
View File

@ -1,905 +0,0 @@
// mysterx.h
#define MX_PATCH_LEVEL ""
#define MX_VERSION MZSCHEME_VERSION // "-" MX_PATCH_LEVEL
#ifndef _SINKTBL_
#include "sinktbl.h"
#endif
#define sizeray(x) (sizeof(x)/sizeof(*x))
#define MXMAIN "mxmain"
#define MX_PRIM_DECL(f) Scheme_Object *f(int,Scheme_Object **)
#define MX_DEFAULT_WIDTH (400)
#define MX_DEFAULT_HEIGHT (400)
#define MAXDIRECTARGS (256)
#define DOCHWND_TRIES 40
#define DOCDISPATCH_TRIES 60
#define MAXARRAYDIMS 32
#define CLSIDLEN 38
#define NORETVALINDEX (-1)
#define UNICODE_BUFFER_SIZE 256
#define TYPE_TBL_SIZE 1019
/* extends INVOKEKIND enum in OAIDL.H */
#define INVOKE_EVENT 16
#define NO_LCID (-1)
typedef HRESULT (STDMETHODCALLTYPE *COMPTR)(IDispatch *);
typedef struct _mx_args_ {
short int numParamsPassed;
short int numOptParams;
short int lcidIndex;
BOOL retvalInParams;
} MX_ARGS_COUNT;
typedef struct _mx_prim_ {
Scheme_Object *(*c_fun)(int argc,Scheme_Object **);
char *name;
short minargs;
short maxargs;
} MX_PRIM;
typedef struct _scheme_com_obj_ {
Scheme_Object so;
BOOL released;
IDispatch *pIDispatch;
ITypeInfo *pITypeInfo;
ITypeInfo *pEventTypeInfo;
CLSID clsId;
IConnectionPoint *pIConnectionPoint;
DWORD connectionCookie;
ISink *pISink;
Scheme_Hash_Table *types;
} MX_COM_Object;
typedef struct _scheme_com_type_ {
Scheme_Object so;
BOOL released;
ITypeInfo *pITypeInfo;
CLSID clsId; // of coclass
} MX_COM_Type;
typedef struct _scheme_mx_event_ {
Scheme_Object so;
BOOL released;
IEvent *pEvent;
} MX_Event;
typedef enum _mx_desckind_ {
funcDesc,varDesc
} MX_DESCKIND;
typedef HRESULT (STDMETHODCALLTYPE *COMFUNPTR)(IDispatch *);
#define NO_FUNPTR (-1)
typedef struct _method_desc_ {
Scheme_Object so;
BOOL released;
MEMBERID memID;
ITypeInfo *pITypeInfo;
ITypeInfo *pITypeInfoImpl;
IDispatch *pInterface;
COMPTR funPtr;
short funOffset; // NO_FUNPTR means no direct call possible
GUID implGuid;
MX_DESCKIND descKind;
union {
struct funcdescs {
FUNCDESC *pFuncDesc;
FUNCDESC *pFuncDescImpl;
} funcdescs;
VARDESC *pVarDesc;
};
} MX_TYPEDESC;
typedef struct _mx_com_data_ {
Scheme_Object so;
BOOL released;
union { // MS representations
DATE date;
CY cy;
SCODE scode;
IUnknown *pIUnknown;
};
} MX_COM_Data_Object;
typedef struct _com_browser_ {
Scheme_Object so;
BOOL released;
HWND hwnd;
IWebBrowser2 *pIWebBrowser2;
ISink *pISink;
IEventQueue *pIEventQueue;
HANDLE readSem;
int *destroy; /* malloc()ed, free()ed by msg loop */
} MX_Browser_Object;
typedef struct _com_document_ {
Scheme_Object so;
BOOL released;
IHTMLDocument2 *pIHTMLDocument2;
} MX_Document_Object;
typedef struct _mx_element_ {
Scheme_Object so;
BOOL released;
BOOL valid;
IHTMLElement *pIHTMLElement;
} MX_Element;
typedef struct _date_ {
Scheme_Object so;
} MX_Date_Object;
typedef struct _mx_omit_ {
Scheme_Object so;
} MX_OMIT;
typedef struct _mx_type_tbl_entry_ {
Scheme_Object so;
IDispatch *pIDispatch;
LPCTSTR name;
INVOKEKIND invKind;
MX_TYPEDESC *pTypeDesc;
struct _mx_type_tbl_entry_ *next;
} MX_TYPE_TBL_ENTRY;
typedef enum _mx_html_where_ {
insert,append
} MX_HTML_WHERE;
typedef struct _browser_window_ { // parameters a la GRacket frame% class
const char *label;
int width;
int height;
int x;
int y;
DWORD style;
} BROWSER_WINDOW;
typedef struct _browser_window_init_ {
BROWSER_WINDOW browserWindow;
IStream **ppIStream; // for passing COM interface back to main thread
int *destroy;
} BROWSER_WINDOW_INIT;
typedef struct _browser_window_style_option {
char *name;
DWORD bits;
BOOL enable;
} BROWSER_WINDOW_STYLE_OPTION;
// dummy type for "subtyping"
// a managed object has a Scheme_Type, followed by a released flag
typedef struct _managed_obj_ {
Scheme_Object so;
BOOL released;
} MX_MANAGED_OBJ;
#define MX_MANAGED_OBJ_RELEASED(o) (((MX_MANAGED_OBJ *)o)->released)
#define TYPE_PRED(o,ty) (!SCHEME_INTP(o) && o->type == ty)
#define MX_COM_OBJP(o) TYPE_PRED(o,mx_com_object_type)
#define MX_COM_OBJ_VAL(o) (((MX_COM_Object *)o)->pIDispatch)
#define MX_COM_OBJ_CONNECTIONPOINT(o) (((MX_COM_Object *)o)->pIConnectionPoint)
#define MX_COM_OBJ_TYPEINFO(o) (((MX_COM_Object *)o)->pITypeInfo)
#define MX_COM_OBJ_CLSID(o) (((MX_COM_Object *)o)->clsId)
#define MX_COM_OBJ_EVENTTYPEINFO(o) (((MX_COM_Object *)o)->pEventTypeInfo)
#define MX_COM_OBJ_EVENTSINK(o) (((MX_COM_Object *)o)->pISink)
#define GUARANTEE_COM_OBJ(fname, argnum) GUARANTEE_TYPE (fname, argnum, MX_COM_OBJP, "com-object")
#define MX_COM_TYPEP(o) TYPE_PRED(o,mx_com_type_type)
#define MX_COM_TYPE_VAL(o) (((MX_COM_Type *)o)->pITypeInfo)
#define GUARANTEE_COM_TYPE(fname, argnum) GUARANTEE_TYPE (fname, argnum, MX_COM_TYPEP, "com-type")
#define MX_COM_OBJ_OR_TYPE(o) (MX_COM_OBJP(o) || MX_COM_TYPEP(o))
#define GUARANTEE_COM_OBJ_OR_TYPE(fname, argnum) \
GUARANTEE_TYPE (fname, argnum, MX_COM_OBJ_OR_TYPE, "com-object or com-type")
#define MX_DOCUMENTP(o) TYPE_PRED(o,mx_document_type)
#define MX_DOCUMENT_VAL(o) (((MX_Document_Object *)o)->pIHTMLDocument2)
#define GUARANTEE_DOCUMENT(fname, argnum) GUARANTEE_TYPE (fname, argnum, MX_DOCUMENTP, "mx-document")
#define MX_BROWSERP(o) TYPE_PRED(o,mx_browser_type)
#define MX_BROWSER_VAL(o) (((MX_Browser_Object *)o)->pIWebBrowser2)
#define MX_BROWSER_EVENTQUEUE(o) (((MX_Browser_Object *)o)->pIEventQueue)
#define MX_BROWSER_SINK(o) (((MX_Browser_Object *)o)->pISink)
#define MX_BROWSER_HWND(o) (((MX_Browser_Object *)o)->hwnd)
#define GUARANTEE_BROWSER(fname, argnum) GUARANTEE_TYPE (fname, argnum, MX_BROWSERP, "mx-browser")
#define MX_ELEMENTP(o) TYPE_PRED(o,mx_element_type)
#define MX_ELEMENT_VALIDITY(o) (((MX_Element *)o)->valid)
#define MX_ELEMENT_VAL(o) (((MX_Element *)o)->pIHTMLElement)
#define GUARANTEE_ELEMENT(fname, argnum) GUARANTEE_TYPE (fname, argnum, MX_ELEMENTP, "mx-element")
#define MX_EVENTP(o) TYPE_PRED(o,mx_event_type)
#define MX_EVENT_VAL(o) (((MX_Event *)o)->pEvent)
#define GUARANTEE_EVENT(fname, argnum) GUARANTEE_TYPE (fname, argnum, MX_EVENTP, "mx-event")
#define MX_CYP(o) TYPE_PRED(o,mx_com_cy_type)
#define MX_CY_VAL(o) (((MX_COM_Data_Object *)o)->cy)
#define GUARANTEE_CY(fname, argnum) GUARANTEE_TYPE (fname, argnum, MX_CYP, "mx-currency")
#define MX_DATEP(o) TYPE_PRED(o,mx_com_date_type)
#define MX_DATE_VAL(o) (((MX_COM_Data_Object *)o)->date)
#define GUARANTEE_DATE(fname, argnum) GUARANTEE_TYPE (fname, argnum, MX_DATEP, "mx-date")
#define MX_SCODEP(o) TYPE_PRED(o,mx_com_scode_type)
#define MX_SCODE_VAL(o) (((MX_COM_Data_Object *)o)->scode)
#define GUARANTEE_SCODE(fname, argnum) GUARANTEE_TYPE (fname, argnum, MX_SCODEP, "mx-scode")
#define MX_IUNKNOWNP(o) TYPE_PRED(o,mx_com_iunknown_type)
#define MX_IUNKNOWN_VAL(o) (((MX_COM_Data_Object *)o)->pIUnknown)
#define GUARANTEE_IUNKNOWN(fname, argnum) GUARANTEE_TYPE (fname, argnum, MX_SCODEP, "mx-iunknown")
#define SCHEME_NONNEGATIVE(thing) (SCHEME_INTP(thing) && SCHEME_INT_VAL(thing) >= 0)
#define GUARANTEE_NONNEGATIVE(fname, argnum) GUARANTEE_TYPE (fname, argnum, SCHEME_NONNEGATIVE, "non-negative integer")
extern const CLSID emptyClsId;
extern Scheme_Type mx_com_object_type;
extern Scheme_Type mx_com_type_type;
extern Scheme_Type mx_browser_type;
extern Scheme_Type mx_document_type;
extern Scheme_Type mx_element_type;
extern Scheme_Type mx_event_type;
extern Scheme_Type mx_com_cy_type;
extern Scheme_Type mx_com_date_type;
extern Scheme_Type mx_com_scode_type;
extern Scheme_Type mx_com_iunknown_type;
extern Scheme_Type mx_com_omit_type;
extern Scheme_Type mx_com_typedesc_type;
extern Scheme_Type mx_tbl_entry_type;
Scheme_Object *mx_make_cy(CY *);
Scheme_Object *mx_make_date(DATE *);
Scheme_Object *mx_make_bool(unsigned);
Scheme_Object *mx_make_scode(SCODE);
Scheme_Object *mx_make_idispatch(IDispatch *);
Scheme_Object *mx_make_iunknown(IUnknown *);
BOOL mx_cy_pred(Scheme_Object *);
BOOL mx_date_pred(Scheme_Object *);
BOOL mx_scode_pred(Scheme_Object *);
BOOL mx_comobj_pred(Scheme_Object *);
BOOL mx_iunknown_pred(Scheme_Object *);
CY mx_cy_val(Scheme_Object *);
DATE mx_date_val(Scheme_Object *);
SCODE mx_scode_val(Scheme_Object *);
IDispatch *mx_comobj_val(Scheme_Object *);
IUnknown *mx_iunknown_val(Scheme_Object *);
// version
MX_PRIM_DECL(mx_version);
// browsers
MX_PRIM_DECL(mx_browser_show);
MX_PRIM_DECL(mx_block_while_browsers);
MX_PRIM_DECL(mx_navigate);
MX_PRIM_DECL(mx_go_back);
MX_PRIM_DECL(mx_go_forward);
MX_PRIM_DECL(mx_refresh);
MX_PRIM_DECL(mx_iconize);
MX_PRIM_DECL(mx_restore);
MX_PRIM_DECL(mx_current_url);
MX_PRIM_DECL(mx_register_navigate_handler);
MX_PRIM_DECL(mx_make_browser);
MX_PRIM_DECL(mx_current_document);
MX_PRIM_DECL(mx_print);
// documents
MX_PRIM_DECL(mx_document_title);
MX_PRIM_DECL(mx_find_element);
MX_PRIM_DECL(mx_find_element_by_id_or_name);
MX_PRIM_DECL(mx_elements_with_tag);
MX_PRIM_DECL(mx_document_objects);
MX_PRIM_DECL(mx_coclass_to_html);
MX_PRIM_DECL(mx_progid_to_html);
MX_PRIM_DECL(mx_insert_html);
MX_PRIM_DECL(mx_append_html);
MX_PRIM_DECL(mx_replace_html);
MX_PRIM_DECL(mx_get_event);
MX_PRIM_DECL(mx_document_pred);
// COM
MX_PRIM_DECL(mx_com_terminate);
MX_PRIM_DECL(mx_com_invoke);
MX_PRIM_DECL(mx_com_set_property);
MX_PRIM_DECL(mx_com_get_property);
MX_PRIM_DECL(mx_com_methods);
MX_PRIM_DECL(mx_com_get_properties);
MX_PRIM_DECL(mx_com_set_properties);
MX_PRIM_DECL(mx_com_events);
MX_PRIM_DECL(mx_com_method_type);
MX_PRIM_DECL(mx_com_get_property_type);
MX_PRIM_DECL(mx_com_set_property_type);
MX_PRIM_DECL(mx_com_event_type);
MX_PRIM_DECL(mx_cocreate_instance_from_coclass);
MX_PRIM_DECL(mx_cocreate_instance_from_progid);
MX_PRIM_DECL(mx_com_get_active_object_from_coclass);
MX_PRIM_DECL(mx_coclass);
MX_PRIM_DECL(mx_progid);
MX_PRIM_DECL(mx_set_coclass);
MX_PRIM_DECL(mx_set_coclass_from_progid);
MX_PRIM_DECL(mx_com_object_eq);
MX_PRIM_DECL(mx_com_object_pred);
MX_PRIM_DECL(mx_com_register_object);
MX_PRIM_DECL(mx_com_release_object);
MX_PRIM_DECL(mx_com_add_ref);
MX_PRIM_DECL(mx_com_ref_count);
MX_PRIM_DECL(mx_com_get_object_type);
MX_PRIM_DECL(mx_com_is_a);
MX_PRIM_DECL(mx_com_help);
MX_PRIM_DECL(mx_com_register_event_handler);
MX_PRIM_DECL(mx_com_unregister_event_handler);
MX_PRIM_DECL(mx_all_controls);
MX_PRIM_DECL(mx_all_coclasses);
// COM types
MX_PRIM_DECL(mx_cy_pred_ex);
MX_PRIM_DECL(mx_currency_to_scheme_number);
MX_PRIM_DECL(scheme_number_to_mx_currency);
MX_PRIM_DECL(mx_date_pred_ex);
MX_PRIM_DECL(mx_date_to_scheme_date);
MX_PRIM_DECL(scheme_date_to_mx_date);
MX_PRIM_DECL(mx_scode_pred_ex);
MX_PRIM_DECL(mx_scode_to_scheme_number);
MX_PRIM_DECL(scheme_number_to_mx_scode);
MX_PRIM_DECL(mx_comobj_pred_ex);
MX_PRIM_DECL(mx_iunknown_pred_ex);
// elements
MX_PRIM_DECL(mx_element_insert_html);
MX_PRIM_DECL(mx_element_append_html);
MX_PRIM_DECL(mx_element_replace_html);
MX_PRIM_DECL(mx_element_insert_text);
MX_PRIM_DECL(mx_element_append_text);
MX_PRIM_DECL(mx_element_get_html);
MX_PRIM_DECL(mx_element_get_text);
MX_PRIM_DECL(mx_element_focus);
MX_PRIM_DECL(mx_element_selection);
MX_PRIM_DECL(mx_element_set_selection);
MX_PRIM_DECL(mx_element_attribute);
MX_PRIM_DECL(mx_element_set_attribute);
MX_PRIM_DECL(mx_element_click);
MX_PRIM_DECL(mx_element_tag);
MX_PRIM_DECL(mx_element_font_family);
MX_PRIM_DECL(mx_element_set_font_family);
MX_PRIM_DECL(mx_element_font_style);
MX_PRIM_DECL(mx_element_set_font_style);
MX_PRIM_DECL(mx_element_font_variant);
MX_PRIM_DECL(mx_element_set_font_variant);
MX_PRIM_DECL(mx_element_font_weight);
MX_PRIM_DECL(mx_element_set_font_weight);
MX_PRIM_DECL(mx_element_font);
MX_PRIM_DECL(mx_element_set_font);
MX_PRIM_DECL(mx_element_background);
MX_PRIM_DECL(mx_element_set_background);
MX_PRIM_DECL(mx_element_background_attachment);
MX_PRIM_DECL(mx_element_set_background_attachment);
MX_PRIM_DECL(mx_element_background_image);
MX_PRIM_DECL(mx_element_set_background_image);
MX_PRIM_DECL(mx_element_background_repeat);
MX_PRIM_DECL(mx_element_set_background_repeat);
MX_PRIM_DECL(mx_element_background_position);
MX_PRIM_DECL(mx_element_set_background_position);
MX_PRIM_DECL(mx_element_text_decoration);
MX_PRIM_DECL(mx_element_set_text_decoration);
MX_PRIM_DECL(mx_element_text_transform);
MX_PRIM_DECL(mx_element_set_text_transform);
MX_PRIM_DECL(mx_element_text_align);
MX_PRIM_DECL(mx_element_set_text_align);
MX_PRIM_DECL(mx_element_margin);
MX_PRIM_DECL(mx_element_set_margin);
MX_PRIM_DECL(mx_element_padding);
MX_PRIM_DECL(mx_element_set_padding);
MX_PRIM_DECL(mx_element_border);
MX_PRIM_DECL(mx_element_set_border);
MX_PRIM_DECL(mx_element_border_top);
MX_PRIM_DECL(mx_element_set_border_top);
MX_PRIM_DECL(mx_element_border_bottom);
MX_PRIM_DECL(mx_element_set_border_bottom);
MX_PRIM_DECL(mx_element_border_left);
MX_PRIM_DECL(mx_element_set_border_left);
MX_PRIM_DECL(mx_element_border_right);
MX_PRIM_DECL(mx_element_set_border_right);
MX_PRIM_DECL(mx_element_border_color);
MX_PRIM_DECL(mx_element_set_border_color);
MX_PRIM_DECL(mx_element_border_width);
MX_PRIM_DECL(mx_element_set_border_width);
MX_PRIM_DECL(mx_element_border_style);
MX_PRIM_DECL(mx_element_set_border_style);
MX_PRIM_DECL(mx_element_border_top_style);
MX_PRIM_DECL(mx_element_set_border_top_style);
MX_PRIM_DECL(mx_element_border_bottom_style);
MX_PRIM_DECL(mx_element_set_border_bottom_style);
MX_PRIM_DECL(mx_element_border_left_style);
MX_PRIM_DECL(mx_element_set_border_left_style);
MX_PRIM_DECL(mx_element_border_right_style);
MX_PRIM_DECL(mx_element_set_border_right_style);
MX_PRIM_DECL(mx_element_style_float);
MX_PRIM_DECL(mx_element_set_style_float);
MX_PRIM_DECL(mx_element_clear);
MX_PRIM_DECL(mx_element_set_clear);
MX_PRIM_DECL(mx_element_display);
MX_PRIM_DECL(mx_element_set_display);
MX_PRIM_DECL(mx_element_visibility);
MX_PRIM_DECL(mx_element_set_visibility);
MX_PRIM_DECL(mx_element_list_style_type);
MX_PRIM_DECL(mx_element_set_list_style_type);
MX_PRIM_DECL(mx_element_list_style_position);
MX_PRIM_DECL(mx_element_set_list_style_position);
MX_PRIM_DECL(mx_element_list_style_image);
MX_PRIM_DECL(mx_element_set_list_style_image);
MX_PRIM_DECL(mx_element_list_style);
MX_PRIM_DECL(mx_element_set_list_style);
MX_PRIM_DECL(mx_element_position);
MX_PRIM_DECL(mx_element_overflow);
MX_PRIM_DECL(mx_element_set_overflow);
MX_PRIM_DECL(mx_element_pagebreak_before);
MX_PRIM_DECL(mx_element_set_pagebreak_before);
MX_PRIM_DECL(mx_element_pagebreak_after);
MX_PRIM_DECL(mx_element_set_pagebreak_after);
MX_PRIM_DECL(mx_element_css_text);
MX_PRIM_DECL(mx_element_set_css_text);
MX_PRIM_DECL(mx_element_cursor);
MX_PRIM_DECL(mx_element_set_cursor);
MX_PRIM_DECL(mx_element_clip);
MX_PRIM_DECL(mx_element_set_clip);
MX_PRIM_DECL(mx_element_filter);
MX_PRIM_DECL(mx_element_set_filter);
MX_PRIM_DECL(mx_element_style_string);
MX_PRIM_DECL(mx_element_text_decoration_none);
MX_PRIM_DECL(mx_element_set_text_decoration_none);
MX_PRIM_DECL(mx_element_text_decoration_underline);
MX_PRIM_DECL(mx_element_set_text_decoration_underline);
MX_PRIM_DECL(mx_element_text_decoration_overline);
MX_PRIM_DECL(mx_element_set_text_decoration_overline);
MX_PRIM_DECL(mx_element_text_decoration_linethrough);
MX_PRIM_DECL(mx_element_set_text_decoration_linethrough);
MX_PRIM_DECL(mx_element_text_decoration_blink);
MX_PRIM_DECL(mx_element_set_text_decoration_blink);
MX_PRIM_DECL(mx_element_pixel_top);
MX_PRIM_DECL(mx_element_set_pixel_top);
MX_PRIM_DECL(mx_element_pixel_left);
MX_PRIM_DECL(mx_element_set_pixel_left);
MX_PRIM_DECL(mx_element_pixel_width);
MX_PRIM_DECL(mx_element_set_pixel_width);
MX_PRIM_DECL(mx_element_pixel_height);
MX_PRIM_DECL(mx_element_set_pixel_height);
MX_PRIM_DECL(mx_element_pos_top);
MX_PRIM_DECL(mx_element_set_pos_top);
MX_PRIM_DECL(mx_element_pos_left);
MX_PRIM_DECL(mx_element_set_pos_left);
MX_PRIM_DECL(mx_element_pos_width);
MX_PRIM_DECL(mx_element_set_pos_width);
MX_PRIM_DECL(mx_element_pos_height);
MX_PRIM_DECL(mx_element_set_pos_height);
MX_PRIM_DECL(mx_element_font_size);
MX_PRIM_DECL(mx_element_set_font_size);
MX_PRIM_DECL(mx_element_color);
MX_PRIM_DECL(mx_element_set_color);
MX_PRIM_DECL(mx_element_background_color);
MX_PRIM_DECL(mx_element_set_background_color);
MX_PRIM_DECL(mx_element_background_position_x);
MX_PRIM_DECL(mx_element_set_background_position_x);
MX_PRIM_DECL(mx_element_background_position_y);
MX_PRIM_DECL(mx_element_set_background_position_y);
MX_PRIM_DECL(mx_element_letter_spacing);
MX_PRIM_DECL(mx_element_set_letter_spacing);
MX_PRIM_DECL(mx_element_vertical_align);
MX_PRIM_DECL(mx_element_set_vertical_align);
MX_PRIM_DECL(mx_element_text_indent);
MX_PRIM_DECL(mx_element_set_text_indent);
MX_PRIM_DECL(mx_element_line_height);
MX_PRIM_DECL(mx_element_set_line_height);
MX_PRIM_DECL(mx_element_margin_top);
MX_PRIM_DECL(mx_element_set_margin_top);
MX_PRIM_DECL(mx_element_margin_bottom);
MX_PRIM_DECL(mx_element_set_margin_bottom);
MX_PRIM_DECL(mx_element_margin_left);
MX_PRIM_DECL(mx_element_set_margin_left);
MX_PRIM_DECL(mx_element_margin_right);
MX_PRIM_DECL(mx_element_set_margin_right);
MX_PRIM_DECL(mx_element_padding_top);
MX_PRIM_DECL(mx_element_set_padding_top);
MX_PRIM_DECL(mx_element_padding_bottom);
MX_PRIM_DECL(mx_element_set_padding_bottom);
MX_PRIM_DECL(mx_element_padding_left);
MX_PRIM_DECL(mx_element_set_padding_left);
MX_PRIM_DECL(mx_element_padding_right);
MX_PRIM_DECL(mx_element_set_padding_right);
MX_PRIM_DECL(mx_element_border_top_color);
MX_PRIM_DECL(mx_element_set_border_top_color);
MX_PRIM_DECL(mx_element_border_bottom_color);
MX_PRIM_DECL(mx_element_set_border_bottom_color);
MX_PRIM_DECL(mx_element_border_left_color);
MX_PRIM_DECL(mx_element_set_border_left_color);
MX_PRIM_DECL(mx_element_border_right_color);
MX_PRIM_DECL(mx_element_set_border_right_color);
MX_PRIM_DECL(mx_element_border_top_width);
MX_PRIM_DECL(mx_element_set_border_top_width);
MX_PRIM_DECL(mx_element_border_bottom_width);
MX_PRIM_DECL(mx_element_set_border_bottom_width);
MX_PRIM_DECL(mx_element_border_left_width);
MX_PRIM_DECL(mx_element_set_border_left_width);
MX_PRIM_DECL(mx_element_border_right_width);
MX_PRIM_DECL(mx_element_set_border_right_width);
MX_PRIM_DECL(mx_element_width);
MX_PRIM_DECL(mx_element_set_width);
MX_PRIM_DECL(mx_element_height);
MX_PRIM_DECL(mx_element_set_height);
MX_PRIM_DECL(mx_element_top);
MX_PRIM_DECL(mx_element_set_top);
MX_PRIM_DECL(mx_element_left);
MX_PRIM_DECL(mx_element_set_left);
MX_PRIM_DECL(mx_element_z_index);
MX_PRIM_DECL(mx_element_set_z_index);
// HTML events
MX_PRIM_DECL(mx_event_keypress_pred);
MX_PRIM_DECL(mx_event_keydown_pred);
MX_PRIM_DECL(mx_event_keyup_pred);
MX_PRIM_DECL(mx_event_mousedown_pred);
MX_PRIM_DECL(mx_event_mouseover_pred);
MX_PRIM_DECL(mx_event_mousemove_pred);
MX_PRIM_DECL(mx_event_mouseout_pred);
MX_PRIM_DECL(mx_event_mouseup_pred);
MX_PRIM_DECL(mx_event_click_pred);
MX_PRIM_DECL(mx_event_dblclick_pred);
MX_PRIM_DECL(mx_event_error_pred);
MX_PRIM_DECL(mx_event_tag);
MX_PRIM_DECL(mx_event_id);
MX_PRIM_DECL(mx_event_from_tag);
MX_PRIM_DECL(mx_event_from_id);
MX_PRIM_DECL(mx_event_to_tag);
MX_PRIM_DECL(mx_event_to_id);
MX_PRIM_DECL(mx_event_keycode);
MX_PRIM_DECL(mx_event_shiftkey);
MX_PRIM_DECL(mx_event_ctrlkey);
MX_PRIM_DECL(mx_event_altkey);
MX_PRIM_DECL(mx_event_x);
MX_PRIM_DECL(mx_event_y);
MX_PRIM_DECL(mx_event_pred);
MX_PRIM_DECL(mx_event_keypress_pred);
MX_PRIM_DECL(mx_event_keydown_pred);
MX_PRIM_DECL(mx_event_keyup_pred);
MX_PRIM_DECL(mx_event_mousedown_pred);
MX_PRIM_DECL(mx_event_mouseover_pred);
MX_PRIM_DECL(mx_event_mouseout_pred);
MX_PRIM_DECL(mx_event_mouseup_pred);
MX_PRIM_DECL(mx_event_click_pred);
MX_PRIM_DECL(mx_event_dblclick_pred);
MX_PRIM_DECL(mx_event_error_pred);
MX_PRIM_DECL(mx_block_until_event);
MX_PRIM_DECL(mx_process_win_events);
MX_PRIM_DECL(mx_release_type_table);
MX_PRIM_DECL(initialize_dotnet_runtime);
void browserHwndMsgLoop(LPVOID);
void mx_register_com_object(Scheme_Object *,IDispatch *);
void mx_register_simple_com_object(Scheme_Object *,IUnknown *);
void scheme_release_browser(void *,void *);
void scheme_release_document(void *,void *);
void codedComError(const char *,HRESULT);
IHTMLElementCollection *getBodyElementsWithTag(IHTMLElement *,LPCTSTR);
IDispatch *getElementInCollection(IHTMLElementCollection *,int);
IDispatch *getObjectInCollection(IHTMLElementCollection *,int);
Scheme_Object *variantToSchemeObject(VARIANTARG *);
void marshalSchemeValueToVariant(Scheme_Object *,VARIANTARG *);
void initEventNames(void);
IHTMLElement *findBodyElement(IHTMLDocument2 *,LPCTSTR,LPCTSTR,int);
CLSID getCLSIDFromCoClass (LPCTSTR);
ITypeInfo *eventTypeInfoFromComObject(MX_COM_Object *);
void signalCodedEventSinkError(char *,HRESULT);
// array procedures
Scheme_Object *safeArrayToSchemeVector(SAFEARRAY *);
SAFEARRAY *schemeVectorToSafeArray(Scheme_Object *, VARTYPE *);
VARTYPE getSchemeVectorType(Scheme_Object *vec);
extern MYSSINK_TABLE myssink_table;
extern HINSTANCE hInstance;
extern HICON hIcon;
extern HANDLE browserHwndMutex;
extern HANDLE createHwndSem;
extern HANDLE eventSinkMutex;
extern HWND browserHwnd;
extern BROWSER_WINDOW_STYLE_OPTION styleOptions[6];
extern WCHAR *eventNames[11];
// misc
extern unsigned long browserCount;
// inline assembly
/* for 4-byte values */
#define pusharg(v) \
__asm { \
push v \
}
/* for single-byte values */
#define pushByte(v) \
__asm { \
mov al,v \
} \
pusharg(eax)
/* for two-byte values */
#define pushShort(v) \
__asm { \
mov ax,v \
} \
pusharg(eax)
/* for 8-byte values */
#define pushWords(v) do \
{ ULONG loWord = (*(ULONG *)(&v)) & 0xFFFFFFFF; \
ULONG hiWord = (ULONG)((*(ULONGLONG *)(&v)) >> 32); \
pusharg(hiWord); \
pusharg(loWord); \
} while (0)
// push right to left
// i indexes argv's, j indexes COM type info
#define pushSuppliedArgs(pFuncDesc,numParamsPassed,argc,argv, \
argVas,vaPtr,va,i,j,lcidIndex,buff) \
do { \
/* j is index into COM type descriptions */ \
j = argc - 3; \
if (lcidIndex != NO_LCID && lcidIndex <= j + 1) { \
j++; \
} \
/* i is index into argv */ \
i = argc - 1; \
if (j > MAXDIRECTARGS - 1) { \
scheme_signal_error("Too many arguments to COM method or property"); \
} \
vaPtr = argVas + j; \
for ( ; j >= 0; i--,j--,vaPtr--) { \
VariantInit(vaPtr); \
if (j == lcidIndex) { \
vaPtr->vt = VT_UI4; \
vaPtr->ulVal = LOCALE_SYSTEM_DEFAULT; \
i++; \
} \
else if (argv[i] == mx_omit_obj) { \
vaPtr->vt = VT_ERROR; \
vaPtr->lVal = DISP_E_PARAMNOTFOUND; \
va = *vaPtr; \
pushVariant(va); \
continue; \
} \
else { \
vaPtr->vt = getVarTypeFromElemDesc(&pFuncDesc->lprgelemdescParam[j]); \
if (vaPtr->vt == VT_VARIANT) { \
marshalSchemeValueToVariant(argv[i],vaPtr); \
va = *vaPtr; \
pushVariant(va); \
continue; \
} \
marshalSchemeValue(argv[i],vaPtr); \
} \
va = *vaPtr; \
pushOneArg(va,buff); \
}; } while (0)
// push right to left
#define pushOptArgs(pFuncDesc,numParamsPassed,numOptParams, \
optArgVas,vaPtr,va,argc,i,j,lcidIndex,buff) \
do { \
if (numOptParams > 0) { \
/* i is index into param type descriptions */ \
i = numParamsPassed - 1; \
if (lcidIndex != NO_LCID) { \
i++; \
} \
/* j is size of VARIANT array */ \
j = i - argc + 3; \
/* lcid to be handled in supplied loop */ \
if (lcidIndex != NO_LCID && lcidIndex < argc - 3) { \
j--; \
} \
if (j > MAXDIRECTARGS) { \
scheme_signal_error("Too many arguments to COM method or property"); \
} \
vaPtr = optArgVas + (j - 1); \
for ( ; j > 0; i--,j--,vaPtr--) { \
VariantInit(vaPtr); \
if (isDefaultParam(pFuncDesc,i)) { \
vaPtr = &(pFuncDesc->lprgelemdescParam[i].paramdesc.pparamdescex->varDefaultValue); \
} \
else if (i == lcidIndex) { \
vaPtr->vt = VT_UI4; \
vaPtr->ulVal = LOCALE_SYSTEM_DEFAULT; \
} \
else { \
vaPtr->vt = VT_ERROR; \
vaPtr->lVal = DISP_E_PARAMNOTFOUND; \
va = *vaPtr; \
pushVariant(va); \
continue; \
} \
va = *vaPtr; \
pushOneArg(va,buff); \
} \
}; } while (0)
/* VARIANT is 16 bytes */
#define pushVariant(va) do {\
ULONGLONG loDword,hiDword; \
loDword = *(ULONGLONG *)&va; \
hiDword = *((ULONGLONG *)&va + 1); \
pushWords(hiDword); \
pushWords(loDword); \
} while (0)
#define pushOneArg(va,buff) \
do {\
switch(va.vt) { \
case VT_I8 : \
pushWords(va.llVal); \
break; \
case VT_I4 : \
pusharg(va.lVal); \
break; \
case VT_UI1 : \
pushByte(va.bVal); \
break; \
case VT_I2 : \
pushShort(va.iVal); \
break; \
case VT_R4 : \
pusharg(va.fltVal); \
break; \
case VT_R8 : \
pushWords(va.dblVal); \
break; \
case VT_BOOL : \
pushShort(va.boolVal); \
break; \
case VT_ERROR : \
pusharg(va.scode); \
break; \
case VT_CY : \
pusharg(va.cyVal); \
break; \
case VT_DATE : \
pushWords(va.date); \
break; \
case VT_BSTR : \
pusharg(va.bstrVal); \
break; \
case VT_UNKNOWN : \
pusharg(va.punkVal); \
break; \
case VT_DISPATCH : \
pusharg(va.pdispVal); \
break; \
case VT_ARRAY : \
pusharg(va.parray); \
break; \
case VT_BYREF|VT_UI1 : \
pusharg(va.pbVal); \
break; \
case VT_BYREF|VT_I2 : \
pusharg(va.piVal); \
break; \
case VT_BYREF|VT_I4 : \
pusharg(va.plVal); \
break; \
case VT_BYREF|VT_I8 : \
pusharg(va.pllVal); \
break; \
case VT_BYREF|VT_R4 : \
pusharg(va.pfltVal); \
break; \
case VT_BYREF|VT_R8 : \
pusharg(va.pdblVal); \
break; \
case VT_BYREF|VT_BOOL : \
pusharg(va.pboolVal); \
break; \
case VT_BYREF|VT_ERROR : \
pusharg(va.pscode); \
break; \
case VT_BYREF|VT_CY : \
pusharg(va.pcyVal); \
break; \
case VT_BYREF|VT_DATE : \
pusharg(va.pdate); \
break; \
case VT_BYREF|VT_BSTR : \
pusharg(va.pbstrVal); \
break; \
case VT_BYREF|VT_UNKNOWN : \
pusharg(va.ppunkVal); \
break; \
case VT_BYREF|VT_PTR : \
case VT_BYREF|VT_DISPATCH : \
pusharg(va.ppdispVal); \
break; \
case VT_BYREF|VT_SAFEARRAY : \
case VT_BYREF|VT_ARRAY : \
pusharg(va.pparray); \
break; \
case VT_BYREF|VT_VARIANT : \
pusharg(va.pvarVal); \
break; \
case VT_I1 : \
pushByte(va.cVal); \
break; \
case VT_UI2 : \
pushShort(va.uiVal); \
break; \
case VT_UI4 : \
pusharg(va.ulVal); \
break; \
case VT_UI8 : \
pushWords(va.ullVal); \
break; \
case VT_INT : \
pusharg(va.intVal); \
break; \
case VT_UINT : \
pusharg(va.uintVal); \
break; \
case VT_VOID : \
/* put property */ \
break; \
case VT_BYREF|VT_I1 : \
pusharg(va.puiVal); \
break; \
case VT_BYREF|VT_UI2 : \
pusharg(va.puiVal); \
break; \
case VT_BYREF|VT_UI4 : \
pusharg(va.pulVal); \
break; \
case VT_BYREF|VT_UI8 : \
pusharg(va.pullVal); \
break; \
case VT_BYREF|VT_INT : \
pusharg(va.pintVal); \
break; \
case VT_BYREF|VT_UINT : \
pusharg(va.puintVal); \
break; \
default : \
sprintf(buff,"Can't push argument with VARIANT tag = %X",va.vt); \
scheme_signal_error(buff); }; } while (0)
void *mx_wrap_handler(Scheme_Object *h);
/* This indirection lets us delayload libmzsch.dll: */
#define scheme_false (scheme_make_false())
#define scheme_true (scheme_make_true())
#define scheme_void (scheme_make_void())
#define scheme_null (scheme_make_null())

28
src/mysterx/mysterx_pre.h
View File

@ -1,28 +0,0 @@
#include "stdafx.h"
#include <stdio.h>
#include <malloc.h>
#include <float.h>
#include <limits.h>
#include <io.h>
#include <process.h>
#define _WIN32_DCOM
#include <objbase.h>
#include <mshtml.h>
#include <initguid.h>
#include <winnls.h>
#include <exdisp.h>
#include <shellapi.h>
#include <htmlhelp.h>
#include "escheme.h"
#ifndef MZ_PRECISE_GC
# define XFORM_OK_PLUS +
# define XFORM_OK_MINUS -
# define GC_CAN_IGNORE /* empty */
# define HIDE_FROM_XFORM(x) x
#endif

BIN
src/mysterx/orgKey.snk
View File

Binary file not shown.

4
src/mysterx/precomp.cxx
View File

@ -1,4 +0,0 @@
/* Precompiled-header stub for xform. */
#include "mysterx_pre.h"

17
src/mysterx/resource.h
View File

@ -1,17 +0,0 @@
//{{NO_DEPENDENCIES}}
// Microsoft Developer Studio generated include file.
// Used by mysterx.rc
//
#define MYSTERX_ICON 101
// Next default values for new objects
//
#ifdef APSTUDIO_INVOKED
#ifndef APSTUDIO_READONLY_SYMBOLS
#define _APS_NO_MFC 1
#define _APS_NEXT_RESOURCE_VALUE 107
#define _APS_NEXT_COMMAND_VALUE 40001
#define _APS_NEXT_CONTROL_VALUE 1000
#define _APS_NEXT_SYMED_VALUE 101
#endif
#endif

18
src/mysterx/stdafx.h
View File

@ -1,18 +0,0 @@
// stdafx.h : include file for standard system include files,
// or project specific include files that are used frequently, but
// are changed infrequently
//
#if !defined(AFX_STDAFX_H__771D254D_69C8_11D2_B535_0060089002FE__INCLUDED_)
#define AFX_STDAFX_H__771D254D_69C8_11D2_B535_0060089002FE__INCLUDED_
#if _MSC_VER > 1000
#pragma once
#endif // _MSC_VER > 1000
// #define WIN32_LEAN_AND_MEAN // Exclude rarely-used stuff from Windows headers
//{{AFX_INSERT_LOCATION}}
// Microsoft Visual C++ will insert additional declarations immediately before the previous line.
#endif // !defined(AFX_STDAFX_H__771D254D_69C8_11D2_B535_0060089002FE__INCLUDED_)

57
src/worksp/README
View File

@ -8,14 +8,18 @@ This directory contains
automatically when using the "configure" script;
- scripts for building 3m variants of Racket and GRacket using Visual
Studio command-line tools; and
Studio command-line tools;
- solution files and project files for building MzCOM and MysterX with
- solution files and project files for building MzCOM with
Microsoft Visual Studio 2008 (not Express, which doesn't support ATL
and MFC).
and MFC);
- solution files and project files for building "myssink.dll" with
Microsoft Visual Studio 2008, although the DLL is normally
downloaded along with other pre-built DLLs.
Visual Studio Express is available for free from Microsoft; it can be
used to build Racket and GRacket, but not MzCOM and MysterX.
used to build Racket and GRacket, but not MzCOM.
Racket and GRacket also compile with Cygwin gcc (a free compiler from
GNU and Cygnus Solutions), but the result is a Unix-style installation,
@ -45,12 +49,12 @@ If you're using MSVC 2008 (not Express), and if `devenv.exe' is in your
path, then you can just run
racket\src\worksp\build.bat
from its own directory to perform all steps up to "Versioning",
including the MzCOM and MysterX steps.
including the MzCOM steps.
If your MSVC environment is configured for 64-bit builds (e.g., by
running "vcvarsall.bat" with "x64), then a 64-bit build is created.
The CGC variants of Racket, GRacket, MzCOM, and MysterX can be built via
The CGC variants of Racket, GRacket, and MzCOM can be built via
Visual Studio projects. The 3m variants are built by a Racket script
that runs the MSVC command-line tools. (See "CGC versus 3m" in
racket\src\README if you don't know about the two variants.)
@ -167,8 +171,8 @@ re-run `raco setup', where "raco.exe" was created the first time.
Versioning
----------
[If you're going to build MzCOM and/or MysterX, do that before running
the version-changing script. See instructions below.]
[If you're going to build MzCOM, do that before running the
version-changing script. See instructions below.]
The obnoxious "xxxxxxx" in the DLL names is a placeholder for a version
number. Embedding a version number in a DLL name appears to be the
@ -190,17 +194,14 @@ and it will re-launch Racket a couple of times. Every ".exe", ".dll",
".lib", ".def", ".exp", and ".pdb" file within the "racket" tree is
updated to replace "xxxxxxxx" with a specific version number.
--------------------------
Building MzCOM and MysterX
--------------------------
Beware that MzCOM and MysterX do not build with Express versions of
Visual Studio. Otherwise, building MzCOMCGC and MysterXCGC is similar
to building RacketCGC. Building the 3m variants is a little different.
--------------
Building MzCOM
--------------
Beware that MzCOM does not build with Express versions of Visual
Studio. Otherwise, building MzCOMCGC is similar to building
RacketCGC. Building the 3m variant is a little different.
To build MzCOMCGC, make the MzCOM solution in
racket\src\worksp\mzcom - makes racket\MzCOMCGC.exe
@ -219,30 +220,6 @@ After building MzCOMCGC, you can build the 3m variant by
The result is racket\MzCOM.exe.
Building MysterX
----------------
To build MysterXCGC, make the MysterX solution in
racket\src\worksp\libmysterx - makes racket\lib\myssink.dll,
racket\lib\myspage.dll, and mxmain.dll in
collects\mysterx\private\compiled\native\win32\i386
Use the "Release" configuration.
After building MysterXCGC, you can build the 3m variant by
1. Change directories to racket\src\worksp\libmysterx and run
..\..\..\racketcgc.exe -cu xform.rkt
2. Switch to the "3m" configuration in the libmysterx solution (in
Visual Studio).
3. Build (in Visual Studio).
The result is mxmain.dll (no 3m suffix) in
collects\mysterx\private\compiled\native\win32\i386\3m
------------
Finding DLLs
------------

13
src/worksp/build.bat
View File

@ -23,6 +23,8 @@ if errorlevel 1 exit /B 1
if errorlevel 1 exit /B 1
..\..\racket -cu ..\get-libs.rkt db ..\..\lib
if errorlevel 1 exit /B 1
..\..\racket -cu ..\get-libs.rkt com ..\..\lib
if errorlevel 1 exit /B 1
cd mzstart
devenv mzstart.sln /Build "Release|%BUILDMODE%"
@ -35,14 +37,6 @@ cd ..
cd mzcom
devenv mzcom.sln /Build "Release|%BUILDMODE%"
if errorlevel 1 exit /B 1
cd ..\libmysterx
devenv libmysterx.sln /Build "Release|%BUILDMODE%"
if errorlevel 1 exit /B 1
cd ..
cd libmysterx
..\..\..\racket -cu xform.rkt
if errorlevel 1 exit /B 1
cd ..
cd mzcom
@ -53,9 +47,6 @@ cd ..
cd mzcom
devenv mzcom.sln /Build "3m|%BUILDMODE%"
if errorlevel 1 exit /B 1
cd ..\libmysterx
devenv libmysterx.sln /Build "3m|%BUILDMODE%"
if errorlevel 1 exit /B 1
cd ..
..\..\racket -N "raco setup" -l- setup %PLT_SETUP_OPTIONS%

24
src/worksp/libmysterx/.gitignore vendored
View File

@ -1,24 +0,0 @@
/libmysterx.ncb
/libmysterx.suo
/dotnet/_dotnet.h
/dotnet/_dotnet_i.c
/dotnet/_dotnet_p.c
/dotnet/_dotnet.idl
/dotnet/_dotnet.tlb
/dotnet/_dotnet.res
/dotnet/dlldata.c
/dotnet/Release
/myspage/Release
/myspage/*.idb
/myspage/*.user
/myspage/x64
/myssink/Release
/myssink/*.idb
/myssink/*.user
/myssink/x64
/gc_traverse.inc
/xsrc

61
src/worksp/libmysterx/libmysterx.sln
View File

@ -1,61 +0,0 @@
Microsoft Visual Studio Solution File, Format Version 10.00
# Visual Studio 2008
Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "myspage", "myspage\myspage.vcproj", "{4F5E803D-985F-43B1-8BDC-B8F6D12F56B8}"
EndProject
Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "myssink", "myssink\myssink.vcproj", "{1B8F4E47-9F2D-45EA-9941-7672B28E8285}"
EndProject
Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "libmysterx", "libmysterx.vcproj", "{68D1B4E0-D9D3-45C3-9BCC-A5491F1F755A}"
ProjectSection(ProjectDependencies) = postProject
{4F5E803D-985F-43B1-8BDC-B8F6D12F56B8} = {4F5E803D-985F-43B1-8BDC-B8F6D12F56B8}
{1B8F4E47-9F2D-45EA-9941-7672B28E8285} = {1B8F4E47-9F2D-45EA-9941-7672B28E8285}
EndProjectSection
EndProject
Global
GlobalSection(SolutionConfigurationPlatforms) = preSolution
3m|Win32 = 3m|Win32
3m|x64 = 3m|x64
Debug|Win32 = Debug|Win32
Debug|x64 = Debug|x64
Release|Win32 = Release|Win32
Release|x64 = Release|x64
EndGlobalSection
GlobalSection(ProjectConfigurationPlatforms) = postSolution
{4F5E803D-985F-43B1-8BDC-B8F6D12F56B8}.3m|Win32.ActiveCfg = Release|Win32
{4F5E803D-985F-43B1-8BDC-B8F6D12F56B8}.3m|Win32.Build.0 = Release|Win32
{4F5E803D-985F-43B1-8BDC-B8F6D12F56B8}.3m|x64.ActiveCfg = Release|x64
{4F5E803D-985F-43B1-8BDC-B8F6D12F56B8}.Debug|Win32.ActiveCfg = Debug|Win32
{4F5E803D-985F-43B1-8BDC-B8F6D12F56B8}.Debug|Win32.Build.0 = Debug|Win32
{4F5E803D-985F-43B1-8BDC-B8F6D12F56B8}.Debug|x64.ActiveCfg = Debug|x64
{4F5E803D-985F-43B1-8BDC-B8F6D12F56B8}.Debug|x64.Build.0 = Debug|x64
{4F5E803D-985F-43B1-8BDC-B8F6D12F56B8}.Release|Win32.ActiveCfg = Release|Win32
{4F5E803D-985F-43B1-8BDC-B8F6D12F56B8}.Release|Win32.Build.0 = Release|Win32
{4F5E803D-985F-43B1-8BDC-B8F6D12F56B8}.Release|x64.ActiveCfg = Release|x64
{4F5E803D-985F-43B1-8BDC-B8F6D12F56B8}.Release|x64.Build.0 = Release|x64
{1B8F4E47-9F2D-45EA-9941-7672B28E8285}.3m|Win32.ActiveCfg = Release|Win32
{1B8F4E47-9F2D-45EA-9941-7672B28E8285}.3m|Win32.Build.0 = Release|Win32
{1B8F4E47-9F2D-45EA-9941-7672B28E8285}.3m|x64.ActiveCfg = Release|x64
{1B8F4E47-9F2D-45EA-9941-7672B28E8285}.Debug|Win32.ActiveCfg = Debug|Win32
{1B8F4E47-9F2D-45EA-9941-7672B28E8285}.Debug|Win32.Build.0 = Debug|Win32
{1B8F4E47-9F2D-45EA-9941-7672B28E8285}.Debug|x64.ActiveCfg = Debug|x64
{1B8F4E47-9F2D-45EA-9941-7672B28E8285}.Debug|x64.Build.0 = Debug|x64
{1B8F4E47-9F2D-45EA-9941-7672B28E8285}.Release|Win32.ActiveCfg = Release|Win32
{1B8F4E47-9F2D-45EA-9941-7672B28E8285}.Release|Win32.Build.0 = Release|Win32
{1B8F4E47-9F2D-45EA-9941-7672B28E8285}.Release|x64.ActiveCfg = Release|x64
{1B8F4E47-9F2D-45EA-9941-7672B28E8285}.Release|x64.Build.0 = Release|x64
{68D1B4E0-D9D3-45C3-9BCC-A5491F1F755A}.3m|Win32.ActiveCfg = 3m|Win32
{68D1B4E0-D9D3-45C3-9BCC-A5491F1F755A}.3m|Win32.Build.0 = 3m|Win32
{68D1B4E0-D9D3-45C3-9BCC-A5491F1F755A}.3m|x64.ActiveCfg = 3m|x64
{68D1B4E0-D9D3-45C3-9BCC-A5491F1F755A}.3m|x64.Build.0 = 3m|x64
{68D1B4E0-D9D3-45C3-9BCC-A5491F1F755A}.Debug|Win32.ActiveCfg = Debug|Win32
{68D1B4E0-D9D3-45C3-9BCC-A5491F1F755A}.Debug|Win32.Build.0 = Debug|Win32
{68D1B4E0-D9D3-45C3-9BCC-A5491F1F755A}.Debug|x64.ActiveCfg = Debug|x64
{68D1B4E0-D9D3-45C3-9BCC-A5491F1F755A}.Debug|x64.Build.0 = Debug|x64
{68D1B4E0-D9D3-45C3-9BCC-A5491F1F755A}.Release|Win32.ActiveCfg = Release|Win32
{68D1B4E0-D9D3-45C3-9BCC-A5491F1F755A}.Release|Win32.Build.0 = Release|Win32
{68D1B4E0-D9D3-45C3-9BCC-A5491F1F755A}.Release|x64.ActiveCfg = Release|x64
{68D1B4E0-D9D3-45C3-9BCC-A5491F1F755A}.Release|x64.Build.0 = Release|x64
EndGlobalSection
GlobalSection(SolutionProperties) = preSolution
HideSolutionNode = FALSE
EndGlobalSection
EndGlobal

Some files were not shown because too many files have changed in this diff Show More