(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)
(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
|#
-;;;; GIO Ports
+;;;; GIO Objects
;;; package: (gtk gio)
(define (open-input-gfile uri)
(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
(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)
(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
(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
(%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))