Mount GFiles as necessary, assuming no password is needed.
authorMatt Birkholz <matt@birkholz.chandler.az.us>
Thu, 11 Aug 2011 00:34:45 +0000 (17:34 -0700)
committerMatt Birkholz <matt@birkholz.chandler.az.us>
Thu, 11 Aug 2011 00:34:45 +0000 (17:34 -0700)
src/gtk/Includes/gio/gfile.cdecl
src/gtk/Includes/gio/gio.cdecl
src/gtk/Includes/gio/gioenums.cdecl
src/gtk/Includes/gio/gmountoperation.cdecl [new file with mode: 0644]
src/gtk/Includes/gobject/gboxed.cdecl [new file with mode: 0644]
src/gtk/Includes/gobject/gparamspecs.cdecl
src/gtk/gio.scm
src/gtk/gtk.cdecl

index 41661fe9d1de91f85ce94ae9f80f05a3be8c6e0b..9c6f2b180603199eb044142f7b756af574ce47ce 100644 (file)
@@ -111,4 +111,19 @@ glib-2.0/gio/gfile.h |#
        g_file_enumerate_children_finish
        (file           (* GFile))
        (res            (* GAsyncResult))
+       (error          (* (* GError))))
+
+(extern void
+       g_file_mount_enclosing_volume
+       (location       (* GFile))
+       (flags          GMountMountFlags)
+       (mount_operation (* GMountOperation))
+       (cancellable    (* GCancellable))
+       (CALLBACK       GAsyncReadyCallback)
+       (ID             gpointer))
+
+(extern gboolean
+       g_file_mount_enclosing_volume_finish
+       (location       (* GFile))
+       (result         (* GAsyncResult))
        (error          (* (* GError))))
\ No newline at end of file
index 113e00bd38f40844ed7b5a875612a235c4cffc1f..47c85f0c9a2e2802794cb608332beacb3b4916f1 100644 (file)
@@ -65,7 +65,7 @@ glib-2.0/gio/gio.h |#
 ;(include "gmemoryinputstream")
 ;(include "gmemoryoutputstream")
 ;(include "gmount")
-;(include "gmountoperation")
+(include "gmountoperation")
 ;(include "gnativevolumemonitor")
 ;(include "gnetworkaddress")
 ;(include "gnetworkservice")
index 2a555b20a8029871ab4478c4a030c808c4fb677e..5c1daee3461525aaf1433b039e9670735444c5e7 100644 (file)
@@ -4,12 +4,6 @@ glib-2.0/gio/gioenums.h |#
 
 (include "../glib-object")
 
-(typedef GFileCreateFlags
-        (enum
-         (G_FILE_CREATE_NONE)
-         (G_FILE_CREATE_PRIVATE)
-         (G_FILE_CREATE_REPLACE_DESTINATION)))
-
 (typedef GFileAttributeType
         (enum
          (G_FILE_ATTRIBUTE_TYPE_INVALID)
@@ -29,6 +23,97 @@ glib-2.0/gio/gioenums.h |#
          (G_FILE_ATTRIBUTE_STATUS_SET)
          (G_FILE_ATTRIBUTE_STATUS_ERROR_SETTING)))
 
-(typedef GFileQueryInfoFlags (enum
+(typedef GFileQueryInfoFlags
+        (enum
          (G_FILE_QUERY_INFO_NONE)
-         (G_FILE_QUERY_INFO_NOFOLLOW_SYMLINKS)))
\ No newline at end of file
+         (G_FILE_QUERY_INFO_NOFOLLOW_SYMLINKS)))
+
+(typedef GFileCreateFlags
+        (enum
+         (G_FILE_CREATE_NONE)
+         (G_FILE_CREATE_PRIVATE)
+         (G_FILE_CREATE_REPLACE_DESTINATION)))
+
+(typedef GMountMountFlags
+        (enum
+         (G_MOUNT_MOUNT_NONE)))
+
+(typedef GMountUnmountFlags
+        (enum
+         (G_MOUNT_UNMOUNT_NONE)
+         (G_MOUNT_UNMOUNT_FORCE)))
+
+(typedef GDriveStartFlags
+        (enum
+         (G_DRIVE_START_NONE)))
+
+(typedef GDriveStartStopType
+        (enum
+         (G_DRIVE_START_STOP_TYPE_UNKNOWN)
+         (G_DRIVE_START_STOP_TYPE_SHUTDOWN)
+         (G_DRIVE_START_STOP_TYPE_NETWORK)
+         (G_DRIVE_START_STOP_TYPE_MULTIDISK)
+         (G_DRIVE_START_STOP_TYPE_PASSWORD)))
+
+(typedef GFileCopyFlags
+        (enum
+         (G_FILE_COPY_NONE)
+         (G_FILE_COPY_OVERWRITE)
+         (G_FILE_COPY_BACKUP)
+         (G_FILE_COPY_NOFOLLOW_SYMLINKS)
+         (G_FILE_COPY_ALL_METADATA)
+         (G_FILE_COPY_NO_FALLBACK_FOR_MOVE)
+         (G_FILE_COPY_TARGET_DEFAULT_PERMS)))
+
+(typedef GFileMonitorFlags
+        (enum
+         (G_FILE_MONITOR_NONE)
+         (G_FILE_MONITOR_WATCH_MOUNTS)
+         (G_FILE_MONITOR_SEND_MOVED)))
+
+(typedef GFileType
+        (enum
+         (G_FILE_TYPE_UNKNOWN)
+         (G_FILE_TYPE_REGULAR)
+         (G_FILE_TYPE_DIRECTORY)
+         (G_FILE_TYPE_SYMBOLIC_LINK)
+         (G_FILE_TYPE_SPECIAL)
+         (G_FILE_TYPE_SHORTCUT)
+         (G_FILE_TYPE_MOUNTABLE)))
+
+(typedef GFilesystemPreviewType
+        (enum
+         (G_FILESYSTEM_PREVIEW_TYPE_IF_ALWAYS)
+         (G_FILESYSTEM_PREVIEW_TYPE_IF_LOCAL)
+         (G_FILESYSTEM_PREVIEW_TYPE_NEVER)))
+
+(typedef GFileMonitorEvent
+        (enum
+         (G_FILE_MONITOR_EVENT_CHANGED)
+         (G_FILE_MONITOR_EVENT_CHANGES_DONE_HINT)
+         (G_FILE_MONITOR_EVENT_DELETED)
+         (G_FILE_MONITOR_EVENT_CREATED)
+         (G_FILE_MONITOR_EVENT_ATTRIBUTE_CHANGED)
+         (G_FILE_MONITOR_EVENT_PRE_UNMOUNT)
+         (G_FILE_MONITOR_EVENT_UNMOUNTED)
+         (G_FILE_MONITOR_EVENT_MOVED)))
+
+(typedef GAskPasswordFlags
+        (enum
+         (G_ASK_PASSWORD_NEED_PASSWORD)
+         (G_ASK_PASSWORD_NEED_USERNAME)
+         (G_ASK_PASSWORD_NEED_DOMAIN)
+         (G_ASK_PASSWORD_SAVING_SUPPORTED)
+         (G_ASK_PASSWORD_ANONYMOUS_SUPPORTED)))
+
+(typedef GPasswordSave
+        (enum
+         (G_PASSWORD_SAVE_NEVER)
+         (G_PASSWORD_SAVE_FOR_SESSION)
+         (G_PASSWORD_SAVE_PERMANENTLY)))
+
+(typedef GMountOperationResult
+        (enum
+         (G_MOUNT_OPERATION_HANDLED)
+         (G_MOUNT_OPERATION_ABORTED)
+         (G_MOUNT_OPERATION_UNHANDLED)))
\ No newline at end of file
diff --git a/src/gtk/Includes/gio/gmountoperation.cdecl b/src/gtk/Includes/gio/gmountoperation.cdecl
new file mode 100644 (file)
index 0000000..4b1da44
--- /dev/null
@@ -0,0 +1,6 @@
+#| -*-Scheme-*-
+
+glib-2.0/gio/gmountoperation.h |#
+
+(extern (* GMountOperation)
+       g_mount_operation_new)
\ No newline at end of file
diff --git a/src/gtk/Includes/gobject/gboxed.cdecl b/src/gtk/Includes/gobject/gboxed.cdecl
new file mode 100644 (file)
index 0000000..0b082bb
--- /dev/null
@@ -0,0 +1,7 @@
+#| -*-Scheme-*-
+
+glib-2.0/gobject/gboxed.h |#
+
+(include "gtype")
+
+(typedef GStrv (* (* gchar)))
\ No newline at end of file
index d5deb19d1ee7e011dff8824fb40ea92b252e7cee..a49851f7b5a046e560fbaecd38d3b5c19eaffeaa 100644 (file)
@@ -4,7 +4,7 @@ glib-2.0/gobject/gparamspecs.h |#
 
 (include "gvalue")
 (include "genums")
-;(include "gboxed")
+(include "gboxed")
 (include "gobject")
 
 (typedef GParamSpecChar (struct _GParamSpecChar))
index 847bd9608a29e823059bb666684115a487b350bd..d8973fab76c69a52c88155f79e7b7c8882f6f32f 100644 (file)
@@ -21,7 +21,7 @@ USA.
 
 |#
 
-;;;; GIO Ports
+;;;; GIO Objects
 ;;; package: (gtk gio)
 
 (define (open-input-gfile uri)
@@ -519,29 +519,34 @@ USA.
               (set-gio-cleanup-info-pending-op! gio-info 'OPEN)
               (set-gio-cleanup-info-callback-id! gio-info id)
               id)))))
-    (C-call "g_file_read_async"
-           (gobject-alien gfile)
-           (gio-priority gstream)
-           (gobject-alien (gio-cleanup-info-gcancellable gio-info))
-           (C-callback "async_ready")
-           callback-id)
-    (let ((value (thread-queue/dequeue! queue)))
-      (if (string? value)
-         (begin
-           (set-gio-cleanup-info-pending-op! gio-info 'ERROR)
-           (error "Error in gfile-read:" gfile value))
-         (begin
-           (set-gio-cleanup-info-pending-op! gio-info #f)
-           (without-interrupts
-            (lambda ()
-              (de-register-c-callback callback-id)
-              (set-gio-cleanup-info-callback-id! gio-info #f)
-              (let ((info (g-input-stream-cleanup-info gstream)))
-                (set-g-input-stream-cleanup-info-read-id!
-                 info (make-read-finish-callback queue gerror*))
-                (set-g-input-stream-cleanup-info-skip-id!
-                 info (make-skip-finish-callback queue gerror*)))))
-           gstream)))))
+    (let retry ()
+      (C-call "g_file_read_async"
+             (gobject-alien gfile)
+             (gio-priority gstream)
+             (gobject-alien (gio-cleanup-info-gcancellable gio-info))
+             (C-callback "async_ready")
+             callback-id)
+      (let ((value (thread-queue/dequeue! queue)))
+       (cond ((eq? value #t)
+              (set-gio-cleanup-info-pending-op! gio-info #f)
+              (without-interrupts
+               (lambda ()
+                 (de-register-c-callback callback-id)
+                 (set-gio-cleanup-info-callback-id! gio-info #f)
+                 (let ((info (g-input-stream-cleanup-info gstream)))
+                   (set-g-input-stream-cleanup-info-read-id!
+                    info (make-read-finish-callback queue gerror*))
+                   (set-g-input-stream-cleanup-info-skip-id!
+                    info (make-skip-finish-callback queue gerror*)))))
+              gstream)
+             ((equal? value "The specified location is not mounted")
+              (gfile-mount gfile)
+              (retry))
+             ((string? value)
+              (set-gio-cleanup-info-pending-op! gio-info 'ERROR)
+              (error (string-append (gfile-uri gfile) ":") value))
+             (else
+              (error "Unexpected value from:" queue gstream)))))))
 
 (define (make-open-finish-callback alien queue gerror*)
   (C-callback
@@ -641,28 +646,34 @@ USA.
               (set-gio-cleanup-info-pending-op! gio-info op)
               (set-gio-cleanup-info-callback-id! gio-info id)
               id)))))
-    (callout (gobject-alien gfile)
-            (gio-priority gstream)
-            (gobject-alien (gio-cleanup-info-gcancellable gio-info))
-            (C-callback "async_ready")
-            callback-id)
-    (let ((value (thread-queue/dequeue! queue)))
-      (if (string? value)
-         (begin
-           (set-gio-cleanup-info-pending-op! gio-info 'ERROR)
-           (error (string "Error in gfile-" op ":") gfile value))
-         (begin
-           (set-gio-cleanup-info-pending-op! gio-info #f)
-           (without-interrupts
-            (lambda ()
-              (de-register-c-callback callback-id)
-              (set-gio-cleanup-info-callback-id! gio-info #f)
-              (let ((info (g-output-stream-cleanup-info gstream)))
-                (set-g-output-stream-cleanup-info-write-id!
-                 info (make-write-finish-callback queue gerror*))
-                (set-g-output-stream-cleanup-info-flush-id!
-                 info (make-flush-finish-callback queue gerror*)))))
-           gstream)))))
+    (let retry ()
+      (callout (gobject-alien gfile)
+              (gio-priority gstream)
+              (gobject-alien (gio-cleanup-info-gcancellable gio-info))
+              (C-callback "async_ready")
+              callback-id)
+      (let ((value (thread-queue/dequeue! queue)))
+       (cond ((or (eq? value #t)
+                  (equal? value "Location is already mounted"))
+              (set-gio-cleanup-info-pending-op! gio-info #f)
+              (without-interrupts
+               (lambda ()
+                 (de-register-c-callback callback-id)
+                 (set-gio-cleanup-info-callback-id! gio-info #f)
+                 (let ((info (g-output-stream-cleanup-info gstream)))
+                   (set-g-output-stream-cleanup-info-write-id!
+                    info (make-write-finish-callback queue gerror*))
+                   (set-g-output-stream-cleanup-info-flush-id!
+                    info (make-flush-finish-callback queue gerror*)))))
+              gstream)
+             ((equal? value "The specified location is not mounted")
+              (gfile-mount gfile)
+              (retry))
+             ((string? value)
+              (set-gio-cleanup-info-pending-op! gio-info 'ERROR)
+              (error (string-append (gfile-uri gfile)":") value))
+             (else
+              (error "Unexpected value from:" queue gstream)))))))
 
 (define-integrable-operator (g-output-stream-finish alien queue gerror* op)
   (if (alien-null? alien)
@@ -698,27 +709,32 @@ USA.
               (set-gio-cleanup-info-pending-op! gio-info 'QUERY)
               (set-gio-cleanup-info-callback-id! gio-info id)
               id)))))
-    (C-call "g_file_query_info_async"
-           (gobject-alien gfile)
-           pattern
-           (if follow-symlinks?
-               (C-enum "G_FILE_QUERY_INFO_NONE")
-               (C-enum "G_FILE_QUERY_INFO_NOFOLLOW_SYMLINKS"))
-           (gio-priority ginfo)
-           (gobject-alien (gio-cleanup-info-gcancellable gio-info))
-           (C-callback "async_ready")
-           callback-id)
-    (let ((value (thread-queue/dequeue! queue)))
-      (if (string? value)
-         (begin
-           (set-gio-cleanup-info-pending-op! gio-info 'ERROR)
-           (error "Error in gfile-query-info:" gfile value))
-         (begin
-           (set-gio-cleanup-info-pending-op! gio-info 'CLOSED)
-           (without-interrupts
-            (lambda ()
-              (cleanup-gio gio-info)))
-           ginfo)))))
+    (let retry ()
+      (C-call "g_file_query_info_async"
+             (gobject-alien gfile)
+             pattern
+             (if follow-symlinks?
+                 (C-enum "G_FILE_QUERY_INFO_NONE")
+                 (C-enum "G_FILE_QUERY_INFO_NOFOLLOW_SYMLINKS"))
+             (gio-priority ginfo)
+             (gobject-alien (gio-cleanup-info-gcancellable gio-info))
+             (C-callback "async_ready")
+             callback-id)
+      (let ((value (thread-queue/dequeue! queue)))
+       (cond ((eq? value #t)
+              (set-gio-cleanup-info-pending-op! gio-info 'CLOSED)
+              (without-interrupts
+               (lambda ()
+                 (cleanup-gio gio-info)))
+              ginfo)
+             ((equal? value "The specified location is not mounted")
+              (gfile-mount gfile)
+              (retry))
+             ((string? value)
+              (set-gio-cleanup-info-pending-op! gio-info 'ERROR)
+              (error (string-append (gfile-uri gfile) ":") value))
+             (else
+              (error "Unexpected value from:" queue ginfo)))))))
 
 (define (make-query-finish-callback alien queue gerror*)
   (C-callback
@@ -841,30 +857,36 @@ USA.
               (set-gio-cleanup-info-pending-op! gio-info 'OPEN)
               (set-gio-cleanup-info-callback-id! gio-info id)
               id)))))
-    (C-call "g_file_enumerate_children_async"
-           (gobject-alien gfile)
-           pattern
-           (if follow-symlinks?
-               (C-enum "G_FILE_QUERY_INFO_NONE")
-               (C-enum "G_FILE_QUERY_INFO_NOFOLLOW_SYMLINKS"))
-           (gio-priority genum)
-           (gobject-alien (gio-cleanup-info-gcancellable gio-info))
-           (C-callback "async_ready")
-           callback-id)
-    (let ((value (thread-queue/dequeue! queue)))
-      (if (string? value)
-         (begin
-           (set-gio-cleanup-info-pending-op! gio-info 'ERROR)
-           (error "Error in gfile-enumerator-children:" gfile value))
-         (begin
-           (set-gio-cleanup-info-pending-op! gio-info #f)
-           (without-interrupts
-            (lambda ()
-              (de-register-c-callback callback-id)
-              (set-gio-cleanup-info-callback-id!
-               gio-info (make-next-files-finish-callback
-                         (gfile-enumerator-ginfos genum) queue gerror*))))
-           genum)))))
+    (let retry ()
+      (C-call "g_file_enumerate_children_async"
+             (gobject-alien gfile)
+             pattern
+             (if follow-symlinks?
+                 (C-enum "G_FILE_QUERY_INFO_NONE")
+                 (C-enum "G_FILE_QUERY_INFO_NOFOLLOW_SYMLINKS"))
+             (gio-priority genum)
+             (gobject-alien (gio-cleanup-info-gcancellable gio-info))
+             (C-callback "async_ready")
+             callback-id)
+      (let ((value (thread-queue/dequeue! queue)))
+       (cond ((eq? value #t)
+              (set-gio-cleanup-info-pending-op! gio-info #f)
+              (without-interrupts
+               (lambda ()
+                 (de-register-c-callback callback-id)
+                 (set-gio-cleanup-info-callback-id!
+                  gio-info
+                  (make-next-files-finish-callback
+                   (gfile-enumerator-ginfos genum) queue gerror*))))
+              genum)
+             ((equal? value "The specified location is not mounted")
+              (gfile-mount gfile)
+              (retry))
+             ((string? value)
+              (set-gio-cleanup-info-pending-op! gio-info 'ERROR)
+              (error (string-append (gfile-uri gfile) ":") value))
+             (else
+              (error "Unexpected value from:" queue genum)))))))
 
 (define (make-enumerator-finish-callback alien queue gerror*)
   (C-callback
@@ -988,6 +1010,109 @@ USA.
           (%trace ";enumerator-close-finish-callback #t "queue"\n")
           (%queue! queue #t))))))
 \f
+(define-class (<g-mount-operation> (constructor ()))
+    (<gio>))
+
+(define-method initialize-instance ((gmount <g-mount-operation>))
+  (call-next-method gmount)
+  (let ((alien (gobject-alien gmount)))
+    (set-alien/ctype! alien '|GMountOperation|)
+    (C-call "g_mount_operation_new" alien)
+    (error-if-null alien "Could not create:" gmount)))
+
+(define (gfile-mount gfile)
+  (let* ((mount-op (make-g-mount-operation))
+        (gio-info (gio-cleanup-info mount-op))
+        (queue (gio-queue mount-op))
+        (gerror* (gio-cleanup-info-gerror-pointer gio-info))
+        (callback-id
+         (without-interrupts           ;don't leak callback IDs
+          (lambda ()
+            (let ((id (make-mount-finish-callback queue gerror*)))
+              (set-gio-cleanup-info-pending-op! gio-info 'MOUNT)
+              (set-gio-cleanup-info-callback-id! gio-info id)
+              id)))))
+    (attach-mount-signal-handlers mount-op gfile)
+    (C-call "g_file_mount_enclosing_volume"
+           (gobject-alien gfile)
+           (C-enum "G_MOUNT_MOUNT_NONE")
+           (gobject-alien mount-op)
+           (gobject-alien (gio-cleanup-info-gcancellable gio-info))
+           (C-callback "async_ready")
+           callback-id)
+    (let ((value (thread-queue/dequeue! queue)))
+      (if (string? value)
+         (begin
+           (set-gio-cleanup-info-pending-op! gio-info 'ERROR)
+           (error "Error during mount:" gfile value))
+         (begin
+           (set-gio-cleanup-info-pending-op! gio-info #f)
+           (gobject-unref! mount-op)
+           (without-interrupts
+            (lambda ()
+              (cleanup-gio gio-info))))))))
+
+(define (make-mount-finish-callback queue gerror*)
+  (C-callback
+   (named-lambda (mount-finish-callback source result)
+     (if (fix:zero? (C-call "g_file_mount_enclosing_volume_finish"
+                           source result gerror*))
+        (let ((message (%gerror-message gerror*)))
+          (%trace ";mount-finish-callback "message" "queue"\n")
+          (%queue! queue message))
+        (begin
+          (%trace ";mount-finish-callback #t "queue"\n")
+          (%queue! queue #t))))))
+
+(define (attach-mount-signal-handlers gmount-op gfile)
+  (g-signal-connect gmount-op (C-callback "ask_password")
+                   (make-mount-password-callback gfile)
+                   'ask-password)
+  (g-signal-connect gmount-op (C-callback "ask_question")
+                   (make-mount-question-callback gfile)
+                   'ask-question)
+  (g-signal-connect gmount-op (C-callback "show_processes")
+                   (make-mount-processes-callback gfile)
+                   'show-processes))
+
+(define (make-mount-password-callback gfile)
+  (named-lambda (mount-password-callback gmount-op message user domain flags)
+    (%trace ";mount-password-callback "(gfile-uri gfile)
+           " "gmount-op
+           " "(c-peek-cstring message)
+           " "(c-peek-cstring user)
+           " "(c-peek-cstring domain)
+           " "(c-flags "GAskPasswordFlags" flags)"\n")
+    ))
+
+(define (c-flags ignore flags)
+  (declare (ignore ignore))
+  (string "0x" (number->string flags 16)))
+
+(define (make-mount-question-callback gfile)
+  (named-lambda (mount-question-callback gmount-op message choices)
+    (%trace ";make-mount-question-callback "(gfile-uri gfile)
+           " "gmount-op
+           " "(c-peek-cstring message)
+           " "(peek-gstrv! choices)"\n")
+    ))
+
+(define (peek-gstrv! alien)
+  (let loop ()
+    (let ((str (c-peek-cstringp! alien)))
+      (if (not str)
+         '()
+         (cons str (loop))))))
+
+(define (make-mount-processes-callback gfile)
+  (named-lambda (mount-processes-callback gmount-op message processes choices)
+    (%trace ";make-mount-processes-callback "gfile
+           " "gmount-op
+           " "(c-peek-cstring message)
+           " "processes
+           " "(peek-gstrv! choices)"\n")
+    ))
+\f
 (define-class (<gfile> (constructor (uri)))
     (<gobject>)
   (uri define accessor))
index 2e207336be35c4d32fb4ae56e898dda3cb93b9e6..0b7eb75f1a43ea5b159b32230343f19bd5bc49e2 100644 (file)
@@ -46,6 +46,30 @@ USA.
          (res (* GAsyncResult))
          (ID gpointer))
 
+(callback void
+         ask_password
+         (op (* GMountOperation))
+         (message (* gchar))
+         (default_user (* gchar))
+         (default_domain (* gchar))
+         (flags GAskPasswordFlags)
+         (ID gpointer))
+
+(callback void
+         ask_question
+         (op (* GMountOperation))
+         (message (* gchar))
+         (choices GStrv)
+         (ID gpointer))
+
+(callback void
+         show_processes
+         (op (* GMountOperation))
+         (message (* gchar))
+         (processes (* GArray))
+         (choices GStrv)
+         (ID gpointer))
+
 ;;; gtkio.c
 
 (extern gboolean start_gtk (argc_loc (* int)) (argv_loc (* (* (* char)))))