ffi/com: repairs for parameterized-property setting and for date values

mflatt · rmculpepper · commit eea9f15a8367 · 2013-04-16T15:01:28.000-04:00
Merge to v5.3.4 (cherry picked from commit 25ddfcb)
diff --git a/collects/ffi/unsafe/com.rkt b/collects/ffi/unsafe/com.rkt
@@ -1251,6 +1251,7 @@
    [(IUnknown? arg) 'iunknown]
    [(eq? com-omit arg) 'any]
    [(box? arg) `(box ,(arg-to-type (unbox arg)))]
+   [(date? arg) 'date]
    [else (error 'com "cannot infer marshal format for value: ~e" arg)]))
 
 (define (elem-desc-ref func-desc i)
@@ -1419,11 +1420,12 @@
                              [wSecond _WORD]
                              [wMilliseconds _WORD]))
 
-(define-ole VariantTimeToSystemTime (_wfun _DATE _SYSTEMTIME-pointer
+(define-oleaut VariantTimeToSystemTime (_wfun _DATE _SYSTEMTIME-pointer
                                            -> _INT))
-(define-ole SystemTimeToVariantTime (_wfun _SYSTEMTIME-pointer (d : (_ptr o _DATE))
-                                           -> (r : _int)
-                                           -> (and (zero? r) d)))
+(define-oleaut SystemTimeToVariantTime (_wfun #:save-errno 'windows
+					      _SYSTEMTIME-pointer (d : (_ptr o _DATE))
+					      -> (r : _int)
+					      -> (and (not (zero? r)) d)))
 
 (define _date
   (make-ctype _DATE
@@ -1438,12 +1440,12 @@
                                            (if (date*? d)
                                                (inexact->exact (floor (* (date*-nanosecond d) 1000)))
                                                0)))
-                (define d (SystemTimeToVariantTime s))
-                (or d
-                    (error 'date "error converting date to COM date")))
+		(or (SystemTimeToVariantTime s)
+		    (error 'date "error converting date to COM date (~a)"
+			   (saved-errno))))
               (lambda (d)
                 (define s (make-SYSTEMTIME 0 0 0 0 0 0 0 0))
-                (unless (zero? (VariantTimeToSystemTime d s))
+                (unless (not (zero? (VariantTimeToSystemTime d s)))
                   (error 'date "error converting date from COM date"))
                 (seconds->date
                  (find-seconds (SYSTEMTIME-wSecond s)
@@ -2072,7 +2074,18 @@
 (define com-set-property!
   (case-lambda
    [(obj name val)
-    (do-com-invoke 'com-set-property! obj name (list val) INVOKE_PROPERTYPUT)]
+    (cond
+     [(string? name)
+      (do-com-invoke 'com-set-property! obj name (list val) INVOKE_PROPERTYPUT)]
+     [(and (list? name)
+	   (pair? name)
+	   (string? (car name)))
+      (do-com-invoke 'com-set-property! obj
+		     (car name) (append (cdr name) (list val))
+		     INVOKE_PROPERTYPUT)]
+     [else
+      (raise-argument-error 'com-set-property! "(or/c string? (cons/c string? list))"
+			    name)])]
    [(obj name1 name2 . names+val)
     (check-com-obj 'com-set-property obj)
     (define names (list* name1 name2 names+val))
diff --git a/collects/mysterx/scribblings/methprop.scrbl b/collects/mysterx/scribblings/methprop.scrbl
@@ -137,22 +137,25 @@ Like @racket[cocreate-instance-from-coclass], but using a ProgID.}
   Returns a list of strings indicating the names of writeable
   properties in @racket[obj/type].}
 
-@defproc[(com-set-property-type [obj/type (or/c com-object? com-type?)] 
-                                [property-name strig?])
+@defproc[(com-set-property-type [obj/type (or/c com-object? com-type?)]
+                                [property-name string?])
           (listof symbol?)]{
 
   Returns a list of symbols indicating the type of the specified
   property in @racket[obj/type]. See @secref["com-types"] for
   information on the symbols.}
 
 @defproc[(com-set-property! [obj com-object?] 
-                            [string? property] ...+
+                            [property (or/c string?
+                                            (cons/c string? list?))] ...+
                             [v any/c])
          void?]{
 
    Sets the value of the final property in @racket[obj] to @racket[v]
    by following the @racket[property]s, where the value of each
-   intermediate property is a COM object.}
+   intermediate property is a COM object. A @racket[property]
+   can be a list instead of a string to represent a parameterized property
+   and its arguments.}
 
 @defproc[(com-help [obj/type (or/c com-object? com-type?)] 
                    [topic string? ""])
diff --git a/collects/scribblings/foreign/com-auto.scrbl b/collects/scribblings/foreign/com-auto.scrbl
@@ -269,14 +269,17 @@ argument.}
   information on the symbols.}
 
 
-@defproc[(com-set-property! [obj com-object?] 
-                            [string? property] ...+
+@defproc[(com-set-property! [obj com-object?]
+                            [property (or/c string?
+                                            (cons/c string? list?))] ...+
                             [v any/c])
          void?]{
 
    Sets the value of the final property in @racket[obj] to @racket[v]
    by following the @racket[property]s, where the value of each
-   intermediate property must be a COM object.
+   intermediate property must be a COM object. A @racket[property]
+   can be a list instead of a string to represent a parameterized property
+   and its arguments.
 
    The type of the property is determined via
    @racket[com-property-type], if possible, and
diff --git a/collects/tests/racket/com.rkt b/collects/tests/racket/com.rkt
@@ -167,4 +167,21 @@
 
   (void))
 
+;; The Excel interface provides many more opportunities for tests:
+(define excel (with-handlers ([exn:fail? (lambda (exn)
+					   (printf "Excel not available\n")
+					   #f)])
+			     (com-create-instance "Excel.Application")))
+(when excel
+  (com-set-property! excel "Visible" #t)
+  (define wb (com-get-property excel "Workbooks"))
+  (define workbook (com-invoke wb "Add"))
+  (define sheets (com-get-property workbook "Worksheets"))
+  (define sheet (com-get-property sheets '("Item" "Sheet1")))
+  (define range (com-get-property sheet "Cells"))
+  (define cell (com-get-property range '("Item" 1 1)))
+  (com-get-property cell '("Value" 10))
+  (com-set-property! cell '("Value" 10) (seconds->date (current-seconds)))
+  (test #t (date? (com-get-property cell '("Value" 10)))))
+
 (printf "~a passed\n" count)
