Menu
▾
▴
[Gtk2hs-commit] (main branch): gnomevfs: initial import
|
From: Duncan C. <dun...@wo...> - 2007-07-05 19:28:27
|
Thu Jul 5 02:42:00 PDT 2007 pg...@gm...
* gnomevfs: initial import
adddir ./demo/gnomevfs
adddir ./gnomevfs
adddir ./gnomevfs/System
adddir ./gnomevfs/System/Gnome
adddir ./gnomevfs/System/Gnome/VFS
hunk ./Makefile.am 22
- gtk/Graphics/UI/Gtk/ModelView/Gtk2HsStore.h
+ gtk/Graphics/UI/Gtk/ModelView/Gtk2HsStore.h \
+ gnomevfs/System/Gnome/VFS/hsfileinfo.h \
+ gnomevfs/marshal.list
hunk ./Makefile.am 62
+if ENABLE_GNOMEVFS
+pkglib_LIBRARIES += libHSgnomevfs.a
+endif
hunk ./Makefile.am 1653
+#
+# gnomevfs package
+#
+################################################################################
+
+if ENABLE_GNOMEVFS
+
+gnomevfs_PKGNAME = libHSgnomevfs_a
+
+libHSgnomevfs_a_NAME = gnomevfs
+libHSgnomevfs_a_CONFIG = gnomevfs/gnomevfs.$(PKGEXT)
+libHSgnomevfs_a_EXTERNALDEPS = base haskell98 mtl
+libHSgnomevfs_a_INTERNALDEPS = glib
+libHSgnomevfs_a_HEADER = libgnomevfs/gnome-vfs.h
+libHSgnomevfs_a_PRECOMP = gnomevfs/gnomevfs.precomp
+libHSgnomevfs_a_LIBS = $(GLIB_LIBS) $(GNOMEVFS_LIBS) $(GCONF_LIBS)
+libHSgnomevfs_a_HCFLAGS = -fffi
+libHSgnomevfs_a_CFLAGS = $(filter-out -I% -D%,$(GLIB_CFLAGS) $(GNOMEVFS_CFLAGS))
+libHSgnomevfs_a_CPPFLAGS = $(filter -I% -D%,$(GLIB_CFLAGS) $(GNOMEVFS_CFLAGS))
+
+libHSgnomevfs_a_SOURCESDIRS = gnomevfs
+
+libHSgnomevfs_a_LIBADD = \
+ gnomevfs/System/Gnome/VFS/Directory_stub.o \
+ gnomevfs/System/Gnome/VFS/Marshal_stub.o \
+ gnomevfs/System/Gnome/VFS/Monitor_stub.o \
+ gnomevfs/System/Gnome/VFS/Xfer_stub.o
+
+if !USE_GCLOSUE_SIGNALS_IMPL
+libHSgnomevfs_a_LIBADD += gnomevfs/System/Gnome/VFS/Signals_stub.o
+endif
+
+gnomevfs/libHSgnomevfs_a.deps : glib/libHSglib_a.deps
+
+libHSgnomevfs_a_GENERATEDSOURCES = \
+ gnomevfs/System/Gnome/VFS/Signals.chs \
+ gnomevfs/System/Gnome/VFS/Hierarchy.chs
+
+nodist_libHSgnomevfs_a_SOURCES = $(libHSgnomevfs_a_GENERATEDSOURCES)
+
+libHSgnomevfs_a_SOURCES = \
+ gnomevfs/System/Gnome/VFS/Types.chs \
+ gnomevfs/System/Gnome/VFS/Error.hs \
+ gnomevfs/System/Gnome/VFS/Marshal.chs \
+ gnomevfs/System/Gnome/VFS/Init.chs \
+ gnomevfs/System/Gnome/VFS/hsfileinfo.c \
+ gnomevfs/System/Gnome/VFS/FileInfo.chs \
+ gnomevfs/System/Gnome/VFS/Monitor.chs \
+ gnomevfs/System/Gnome/VFS/Ops.chs \
+ gnomevfs/System/Gnome/VFS/Directory.chs \
+ gnomevfs/System/Gnome/VFS/URI.chs \
+ gnomevfs/System/Gnome/VFS/Util.chs \
+ gnomevfs/System/Gnome/VFS/Xfer.chs \
+ gnomevfs/System/Gnome/VFS/Cancellation.chs \
+ gnomevfs/System/Gnome/VFS/Volume.chs \
+ gnomevfs/System/Gnome/VFS/Drive.chs \
+ gnomevfs/System/Gnome/VFS/VolumeMonitor.chs \
+ gnomevfs/System/Gnome/VFS/MIME.chs \
+ gnomevfs/System/Gnome/VFS.hs
+
+htmldoc_HSFILES_HIDDEN += \
+ $(libHSgnomevfs_a_GENERATEDSOURCES:.chs=.hs) \
+ gnomevfs/System/Gnome/VFS/Types.hs \
+ gnomevfs/System/Gnome/VFS/Marshal.hs
+
+gnomevfs_System_Gnome_VFS_FileInfo_hs_HCFLAGS = '-\#include "hsfileinfo.h"'
+gnomevfs_System_Gnome_VFS_MIME_hs_HCFLAGS = '-\#include "libgnomevfs/gnome-vfs-mime.h"'
+gnomevfs_System_Gnome_VFS_Types_hs_HCFLAGS = -fglasgow-exts
+gnomevfs_System_Gnome_VFS_Directory_hs_HCFLAGS = -fglasgow-exts
+
+libHSgnomevfs_a_ALLSOURCES = $(libHSgnomevfs_a_SOURCES) $(nodist_libHSgnomevfs_a_SOURCES)
+
+gnomevfs/System/Gnome/VFS/Hierarchy.chs : \
+ $(srcdir)/tools/hierarchyGen/hierarchy.list \
+ $(srcdir)/tools/hierarchyGen/TypeGenerator$(EXEEXT) \
+ $(srcdir)/tools/hierarchyGen/Hierarchy.chs.template
+ $(strip $(srcdir)/tools/hierarchyGen/TypeGenerator$(EXEEXT) \
+ $(srcdir)/tools/hierarchyGen/hierarchy.list \
+ $(srcdir)/tools/hierarchyGen/Hierarchy.chs.template \
+ $@ --tag=gnomevfs --lib=gnomevfs --prefix=gnome_vfs \
+ --modname=System.Gnome.VFS.Hierarchy --parentname=System.Glib.GObject)
+
+gnomevfs/System/Gnome/VFS/Signals.chs : \
+ $(srcdir)/tools/callbackGen/Signal.chs.template \
+ $(srcdir)/gnomevfs/marshal.list \
+ $(srcdir)/tools/callbackGen/HookGenerator$(EXEEXT)
+ $(strip $(srcdir)/tools/callbackGen/HookGenerator$(EXEEXT) \
+ $(srcdir)/gnomevfs/marshal.list \
+ $(srcdir)/tools/callbackGen/Signal.chs.template $@ \
+ System.Gnome.VFS.Signals)
+
+am_libHSgnomevfs_a_OBJECTS = \
+ $(addsuffix .$(OBJEXT),$(basename $(basename $(libHSgnomevfs_a_ALLSOURCES))))
+
+libHSgnomevfs_a_HSPPFILES = $(filter %.hs.pp, $(libHSgnomevfs_a_ALLSOURCES))
+libHSgnomevfs_a_CHSPPFILES = $(filter %.chs.pp,$(libHSgnomevfs_a_ALLSOURCES))
+libHSgnomevfs_a_CHSFILES = \
+ $(filter %.chs,$(libHSgnomevfs_a_ALLSOURCES:.chs.pp=.chs))
+libHSgnomevfs_a_CHSFILES_HS = $(libHSgnomevfs_a_CHSFILES:.chs=.hs)
+libHSgnomevfs_a_HSCFILES = $(filter %.hsc, $(libHSgnomevfs_a_ALLSOURCES))
+libHSgnomevfs_a_HSCFILES_HS = $(libHSgnomevfs_a_HSCFILES:.hsc=.hs)
+libHSgnomevfs_a_BUILDSOURCES = \
+ $(libHSgnomevfs_a_HSPPFILES:.hs.pp=.hs) \
+ $(libHSgnomevfs_a_CHSPPFILES:.chs.pp=.chs) \
+ $(libHSgnomevfs_a_CHSFILES_HS) \
+ $(libHSgnomevfs_a_HSCFILES_HS) \
+ $(libHSgnomevfs_a_GENERATEDSOURCES)
+libHSgnomevfs_a_HSFILES = \
+ $(filter %.hs,$(libHSgnomevfs_a_BUILDSOURCES)) \
+ $(filter %.hs,$(libHSgnomevfs_a_ALLSOURCES))
+libHSgnomevfs_a_CFILES = $(filter %.c,$(libHSgnomevfs_a_ALLSOURCES))
+
+nobase_hi_DATA += $(libHSgnomevfs_a_HSFILES:.hs=.hi)
+
+gnomevfs_MOSTLYCLEANFILES = $(am_libHSgnomevfs_a_OBJECTS)
+gnomevfs_MOSTLYCLEANFILES += $(libHSgnomevfs_a_HSFILES:.hs=.hi)
+gnomevfs_MOSTLYCLEANFILES += $(libHSgnomevfs_a_CHSFILES:.chs=.chi)
+gnomevfs_MOSTLYCLEANFILES += $(libHSgnomevfs_a_CHSFILES:.chs=.h)
+gnomevfs_MOSTLYCLEANFILES += $(libHSgnomevfs_a_CHSFILES:.chs=_stub.h)
+gnomevfs_MOSTLYCLEANFILES += $(libHSgnomevfs_a_CHSFILES:.chs=_stub.o)
+gnomevfs_MOSTLYCLEANFILES += $(libHSgnomevfs_a_CHSFILES:.chs=_stub.c)
+gnomevfs_CLEANFILES = $(libHSgnomevfs_a_BUILDSOURCES)
+gnomevfs_CLEANFILES += $(libHSgnomevfs_a_CHSFILES_HS:.hs=.dep)
+
+$(libHSgnomevfs_a_CHSFILES:.chs=.dep) : \
+ $(libHSgnomevfs_a_GENERATEDSOURCES)
+
+ifeq (,$(findstring clean,$(MAKECMDGOALS)))
+-include $(libHSgnomevfs_a_CHSFILES:.chs=.dep) gnomevfs/libHSgnomevfs_a.deps
+ endif
+
+if ENABLE_SPLITOBJS
+libHSgnomevfs_a_AR = $(srcdir)/mk/link-splitobjs.sh
+else
+libHSgnomevfs_a_AR = $(AR) $(ARFLAGS)
+endif
+
+libHSgnomevfs_a_DEPENDENCIES = HSgnomevfs.o
+pkglib_DATA += HSgnomevfs.o
+HSgnomevfs.o : $(libHSgnomevfs_a_OBJECTS)
+ $(LD) -r $(LD_X) -o $@ $(libHSgnomevfs_a_OBJECTS) $(libHSgnomevfs_a_LIBADD)
+
+if ENABLE_PROFILING
+libHSgnomevfs_a_DEPENDENCIES += libHSgnomevfs_p.a
+pkglib_DATA += libHSgnomevfs_p.a
+libHSgnomevfs_p.a : $(libHSgnomevfs_a_HSFILES:.hs=.p_o) \
+ $(libHSgnomevfs_a_LIBADD:.o=.p_o)
+ $(AR) $(ARFLAGS) $@ $^
+
+ifeq (,$(findstring clean,$(MAKECMDGOALS)))
+-include gnomevfs/libHSgnomevfs_a.p_deps
+ endif
+
+nobase_hi_DATA += $(libHSgnomevfs_a_HSFILES:.hs=.p_hi)
+gnomevfs_MOSTLYCLEANFILES += $(libHSgnomevfs_a_HSFILES:.hs=.p_hi)
+gnomevfs_MOSTLYCLEANFILES += $(libHSgnomevfs_a_HSFILES:.hs=.p_o)
+gnomevfs_MOSTLYCLEANFILES += $(libHSgnomevfs_a_LIBADD:.o=.p_o)
+
+endif
+
+endif
+
hunk ./Makefile.am 2135
+ rm -f $(gnomevfs_MOSTLYCLEANFILES)
hunk ./Makefile.am 2150
+ rm -f $(gnomevfs_CLEANFILES)
hunk ./configure.ac 343
+GTKHS_PKG_CHECK(gnomevfs, gnomevfs, GNOMEVFS, [gnome-vfs-2.0 >= 2.0.0],
+ [build gnome-vfs package (default=auto)],
+ [gnomevfs library requirement not met. Perhaps you need to install libgnomevfs or libgnomevfs-devel])
hunk ./configure.ac 629
+GTKHS_REFORMAT_PACKAGE_CFLAGS(GNOMEVFS_CFLAGS, GNOMEVFS_CFLAGS_CQ)
+GTKHS_REFORMAT_PACKAGE_LIBS(GNOMEVFS_LIBS, GNOMEVFS_LIBS_CQ, GNOMEVFS_LIBDIR_CQ, GNOMEVFS_LIBEXTRA_CQ)
+AC_SUBST(GNOMEVFS_CFLAGS_CQ)
+AC_SUBST(GNOMEVFS_LIBS_CQ)
+AC_SUBST(GNOMEVFS_LIBDIR_CQ)
+AC_SUBST(GNOMEVFS_LIBEXTRA_CQ)
+
hunk ./configure.ac 863
+
+ gnomevfs/gnomevfs.pkg
+ gnomevfs/gnomevfs.package.conf
+ gnomevfs/gnomevfs.cabal
hunk ./configure.ac 887
+echo "* gnomevfs : ${ENABLE_GNOMEVFS} "
addfile ./demo/gnomevfs/Makefile
hunk ./demo/gnomevfs/Makefile 1
+
+PROGS = test-sync test-dir test-xfer test-drive-volume
+SOURCES = TestSync.hs TestDir.hs TestXfer.hs TestDriveVolume.hs
+
+all: $(PROGS)
+
+test-sync : TestSync.hs
+ $(HC_RULE)
+test-dir : TestDir.hs
+ $(HC_RULE)
+test-xfer : TestXfer.hs
+ $(HC_RULE)
+test-drive-volume : TestDriveVolume.hs
+ $(HC_RULE)
+
+HC_RULE = $(HC) --make $< -o $@ $(HCFLAGS)
+
+clean:
+ rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS)
+
+HC=ghc
addfile ./demo/gnomevfs/TestDir.hs
hunk ./demo/gnomevfs/TestDir.hs 1
+module Main where
+
+import qualified System.Gnome.VFS as VFS
+import Control.Exception ( handleJust )
+import Control.Monad ( when
+ , liftM )
+import Data.Maybe ( fromMaybe )
+import Text.Printf ( printf )
+import System.Time ( ClockTime(..)
+ , calendarTimeToString
+ , toCalendarTime )
+import System.IO
+import System.Exit
+import System.Environment
+
+handleVFSError vfsError =
+ let VFS.Error result = vfsError
+ in do hPutStrLn stderr $ "VFS error: " ++ show result
+ exitFailure
+
+directoryVisitCallback :: String
+ -> VFS.FileInfo
+ -> Bool
+ -> IO VFS.DirectoryVisitResult
+directoryVisitCallback name fileInfo recursingWillLoop =
+ do mTimeStr <- case VFS.fileInfoMTime fileInfo of
+ Just mTime -> liftM calendarTimeToString $
+ toCalendarTime $ TOD (fromIntegral $ fromEnum mTime) 0
+ Nothing -> return "unknown"
+ let name = fromMaybe "unknown" (VFS.fileInfoName fileInfo)
+ size = VFS.formatFileSizeForDisplay (fromMaybe 0 (VFS.fileInfoSize fileInfo))
+ [_$_]
+ printf "%20s %20s %s\n" size mTimeStr name
+ return VFS.DirectoryVisitContinue
+
+main :: IO ()
+main =
+ handleJust VFS.errors handleVFSError $
+ do progName <- getProgName
+ args <- getArgs
+ [_$_]
+ when (length args /= 1) $
+ do hPutStrLn stderr $ "Usage: " ++ progName ++ " <uri>"
+ exitFailure
+ [_$_]
+ VFS.init >>= (\success ->
+ when (not success) $
+ do hPutStrLn stderr $ "could not initialize GnomeVFS"
+ exitFailure)
+ [_$_]
+ let textURI = head args
+ uri <- case VFS.uriFromString textURI of
+ Nothing -> do hPutStrLn stderr $ "Invalid URI: " ++ textURI
+ exitFailure
+ Just uri -> return uri
+ [_$_]
+ VFS.directoryVisit textURI [] [] directoryVisitCallback
addfile ./demo/gnomevfs/TestDriveVolume.hs
hunk ./demo/gnomevfs/TestDriveVolume.hs 1
+module Main where
+
+import qualified System.Gnome.VFS as VFS
+import Control.Exception ( handleJust )
+import Control.Monad ( when
+ , liftM )
+import Data.Maybe ( fromMaybe )
+import Text.Printf ( printf )
+import System.IO
+import System.Exit
+
+handleVFSError vfsError =
+ let VFS.Error result = vfsError
+ in do hPutStrLn stderr $ "VFS error: " ++ show result
+ exitFailure
+
+main :: IO ()
+main =
+ handleJust VFS.errors handleVFSError $
+ do VFS.init >>= (\success ->
+ when (not success) $
+ do hPutStrLn stderr $ "could not initialize GnomeVFS"
+ exitFailure)
+ [_$_]
+ drives <- VFS.volumeMonitorGetConnectedDrives VFS.volumeMonitor
+ flip mapM_ drives $ \drive ->
+ do VFS.driveGetDisplayName drive >>= printf "Drive %s:\n"
+ VFS.driveGetDeviceType drive >>= (printf "\tDevice Type: %s\n") . show
+ VFS.driveGetDevicePath drive >>= (printf "\tDevice Path: %s\n") . show
+ volumes <- VFS.driveGetMountedVolumes drive
+ flip mapM_ volumes $ \volume ->
+ do VFS.volumeGetDisplayName volume >>= printf "\tVolume %s:\n"
+ VFS.volumeGetDevicePath volume >>= printf "\t\tDevice Path: %s\n"
+ VFS.volumeGetFilesystemType volume >>= printf "\t\tFilesystem Type: %s\n"
+ [_$_]
+ return ()
addfile ./demo/gnomevfs/TestSync.hs
hunk ./demo/gnomevfs/TestSync.hs 1
+module Main where
+
+import qualified System.Gnome.VFS as VFS
+import Control.Exception
+import Control.Monad (when)
+import Data.Maybe (fromMaybe)
+import System.IO
+import System.Exit
+import System.Environment
+import qualified Data.ByteString as BS
+
+handleVFSError vfsError =
+ let VFS.Error result = vfsError
+ in do hPutStrLn stderr $ "VFS error: " ++ show result
+ exitFailure
+
+main :: IO ()
+main = [_$_]
+ handleJust VFS.errors handleVFSError $
+ do progName <- getProgName
+ args <- getArgs
+ [_$_]
+ when (length args /= 1) $
+ do hPutStrLn stderr $ "Usage: " ++ progName ++ " <uri>"
+ exitFailure
+ [_$_]
+ VFS.init >>= (\success ->
+ when (not success) $
+ do hPutStrLn stderr $ "could not initialize GnomeVFS"
+ exitFailure)
+ [_$_]
+ let textURI = head args
+ uri <- case VFS.uriFromString textURI of
+ Nothing -> do hPutStrLn stderr $ "Invalid URI: " ++ textURI
+ exitFailure
+ Just uri -> return uri
+ [_$_]
+ handle <- VFS.openURI uri VFS.OpenRead
+ fileInfo <- VFS.getFileInfoFromHandle handle []
+ let blockSize = fromMaybe 4096 $ VFS.fileInfoIOBlockSize fileInfo
+ [_$_]
+ let loop = handleJust VFS.errors
+ (\(VFS.Error result) ->
+ case result of
+ VFS.ErrorEof -> return ()
+ _ -> handleVFSError $ VFS.Error result) $
+ do bytes <- VFS.read handle blockSize
+ BS.putStr bytes
+ loop
+ loop
+ [_$_]
+ VFS.close handle
addfile ./demo/gnomevfs/TestXfer.hs
hunk ./demo/gnomevfs/TestXfer.hs 1
+module Main where
+
+import qualified System.Gnome.VFS as VFS
+import Control.Exception ( handleJust )
+import Control.Monad ( when
+ , liftM )
+import Data.Maybe ( fromMaybe )
+import Text.Printf ( printf )
+import System.IO
+import System.Exit
+import System.Environment
+
+handleVFSError vfsError =
+ let VFS.Error result = vfsError
+ in do hPutStrLn stderr $ "VFS error: " ++ show result
+ exitFailure
+
+xferProgressCallback :: VFS.XferProgressCallback
+xferProgressCallback info =
+ do printf "Status: %s\tPhase: %s\n"
+ (show $ VFS.xferProgressInfoVFSStatus info)
+ (show $ VFS.xferProgressInfoPhase info)
+ printf "\tSource: %s\n\tTarget: %s\n"
+ (show $ VFS.xferProgressInfoSourceName info)
+ (show $ VFS.xferProgressInfoTargetName info)
+ printf "\t%d of %d files\n"
+ (toInteger $ VFS.xferProgressInfoFileIndex info)
+ (toInteger $ VFS.xferProgressInfoFilesTotal info)
+ printf "\t%s of %s\n"
+ (VFS.formatFileSizeForDisplay $ VFS.xferProgressInfoBytesCopied info)
+ (VFS.formatFileSizeForDisplay $ VFS.xferProgressInfoFileSize info)
+ printf "\t%s of %s total\n"
+ (VFS.formatFileSizeForDisplay $ VFS.xferProgressInfoTotalBytesCopied info)
+ (VFS.formatFileSizeForDisplay $ VFS.xferProgressInfoBytesTotal info)
+ return True
+
+xferErrorCallback :: VFS.XferErrorCallback
+xferErrorCallback info =
+ do printf "error: %s; aborting transfer\n" $ show $ VFS.xferProgressInfoVFSStatus info
+ return VFS.XferErrorActionAbort
+
+xferOverwriteCallback :: VFS.XferOverwriteCallback
+xferOverwriteCallback info =
+ do printf "skipping file %s as it already exists\n" $ fromMaybe "unknown" $ VFS.xferProgressInfoSourceName info
+ return VFS.XferOverwriteActionSkip
+
+main :: IO ()
+main =
+ handleJust VFS.errors handleVFSError $
+ do progName <- getProgName
+ args <- getArgs
+ [_$_]
+ when (length args /= 2) $
+ do hPutStrLn stderr $ "Usage: " ++ progName ++ " source target"
+ exitFailure
+ [_$_]
+ VFS.init >>= (\success ->
+ when (not success) $
+ do hPutStrLn stderr $ "could not initialize GnomeVFS"
+ exitFailure)
+ [_$_]
+ hPutStrLn stderr "vfs initialized"
+ [_$_]
+ let [source, target] = args
+ [_$_]
+ hPutStrLn stderr "parsing source URI"
+ [_$_]
+ sourceURI <- case VFS.uriFromString source of
+ Just sourceURI -> return sourceURI
+ Nothing -> do hPutStrLn stderr $ "invalid source URI"
+ exitFailure
+ [_$_]
+ hPutStrLn stderr "parsing target URI"
+ [_$_]
+ targetURI <- case VFS.uriFromString target of
+ Just targetURI -> return targetURI
+ Nothing -> do hPutStrLn stderr $ "invalid target URI"
+ exitFailure
+ [_$_]
+ hPutStrLn stderr "executing transfer"
+ [_$_]
+ VFS.xferURI sourceURI targetURI []
+ VFS.XferErrorModeQuery VFS.XferOverwriteModeQuery
+ (Just xferProgressCallback) (Just xferErrorCallback)
+ (Just xferOverwriteCallback) Nothing
+ [_$_]
+ return ()
addfile ./gnomevfs/System/Gnome/VFS.hs
hunk ./gnomevfs/System/Gnome/VFS.hs 1
+-- GIMP Toolkit (GTK) Binding for Haskell: binding to libgnomevfs -*-haskell-*-
+--
+-- Author : Peter Gavin
+-- Created: 1-Apr-2007
+--
+-- Copyright (c) 2007 Peter Gavin
+--
+-- This library is free software; you can redistribute it and/or
+-- modify it under the terms of the GNU Library General Public
+-- License as published by the Free Software Foundation; either
+-- version 2 of the License, or (at your option) any later version.
+--
+-- This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+-- Library General Public License for more details.
+--
+-- | Maintainer : gtk...@li...
+-- Stability : alpha
+-- Portability : portable (depends on GHC)
+module System.Gnome.VFS (
+ [_$_]
+ module System.Gnome.VFS.Cancellation,
+ module System.Gnome.VFS.Directory,
+ module System.Gnome.VFS.Drive,
+ module System.Gnome.VFS.Error,
+ module System.Gnome.VFS.FileInfo,
+ module System.Gnome.VFS.Init,
+ module System.Gnome.VFS.MIME,
+ module System.Gnome.VFS.Monitor,
+ module System.Gnome.VFS.Ops,
+ module System.Gnome.VFS.URI,
+ module System.Gnome.VFS.Util,
+ module System.Gnome.VFS.Volume,
+ module System.Gnome.VFS.VolumeMonitor,
+ module System.Gnome.VFS.Xfer
+
+ ) where
+
+import System.Gnome.VFS.Cancellation
+import System.Gnome.VFS.Directory
+import System.Gnome.VFS.Drive
+import System.Gnome.VFS.Error
+import System.Gnome.VFS.FileInfo
+import System.Gnome.VFS.Init
+import System.Gnome.VFS.MIME
+import System.Gnome.VFS.Monitor
+import System.Gnome.VFS.Ops
+import System.Gnome.VFS.URI
+import System.Gnome.VFS.Util
+import System.Gnome.VFS.Volume
+import System.Gnome.VFS.VolumeMonitor
+import System.Gnome.VFS.Xfer
addfile ./gnomevfs/System/Gnome/VFS/Cancellation.chs
hunk ./gnomevfs/System/Gnome/VFS/Cancellation.chs 1
+-- GIMP Toolkit (GTK) Binding for Haskell: binding to libgnomevfs -*-haskell-*-
+--
+-- Author : Peter Gavin
+-- Created: 1-Apr-2007
+--
+-- Copyright (c) 2007 Peter Gavin
+--
+-- This library is free software; you can redistribute it and/or
+-- modify it under the terms of the GNU Library General Public
+-- License as published by the Free Software Foundation; either
+-- version 2 of the License, or (at your option) any later version.
+--
+-- This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+-- Library General Public License for more details.
+--
+-- | Maintainer : gtk...@li...
+-- Stability : alpha
+-- Portability : portable (depends on GHC)
+module System.Gnome.VFS.Cancellation (
+ [_$_]
+-- * Types
+ Cancellation,
+
+-- * Cancellation creation
+ cancellationNew,
+
+-- * Cancellation notification
+ cancellationCancel,
+ cancellationCheck,
+ cancellationAck,
+
+-- * Other Operations
+ cancellationGetFD
+ [_$_]
+ ) where
+
+import Control.Monad (liftM)
+import System.Glib.FFI
+{#import System.Gnome.VFS.Types#}
+import System.Posix.Types (Fd)
+
+{# context lib = "gnomevfs" prefix = "gnome_vfs" #}
+
+-- | Create a new 'Cancellation' object for reporting
+-- cancellation to a gnome-vfs module.
+cancellationNew :: IO Cancellation -- ^ a new 'Cancellation' object
+cancellationNew =
+ {# call cancellation_new #} >>= newCancellation
+
+-- | Send a cancellation request through a 'Cancellation' object.
+cancellationCancel :: Cancellation -- ^ @cancellation@ - the object to request cancellation through
+ -> IO ()
+cancellationCancel cancellation =
+ {# call cancellation_cancel #} cancellation
+
+-- | Check for pending cancellation.
+cancellationCheck :: Cancellation -- ^ @cancellation@ - the object to check for cancellation
+ -> IO Bool -- ^ 'True' if cancellation has been requested, 'False' otherwise
+cancellationCheck cancellation =
+ liftM toBool $ {# call cancellation_check #} cancellation
+
+-- | Acknowledge a cancellation. This should be called if
+-- 'cancellationCheck' returns 'True'.
+cancellationAck :: Cancellation -- ^ @cancellation@ - the object to achnowledge cancellation
+ -> IO ()
+cancellationAck cancellation =
+ {# call cancellation_ack #} cancellation
+
+-- | Get a file descriptor-based notificator for cancellation. When
+-- cancellation receives a cancellation request, a character will be
+-- made available on the returned file descriptor for input.
+-- [_$_]
+-- This is very useful for detecting cancellation during I\/O
+-- operations: you can use the select() call to check for available
+-- input\/output on the file you are reading\/writing, and on the
+-- notificator's file descriptor at the same time. If a data is
+-- available on the notificator's file descriptor, you know you have
+-- to cancel the read\/write operation.
+cancellationGetFD :: Cancellation -- ^ @cancellation@ - the object to get a file descriptor for
+ -> IO Fd -- ^ the file descriptor
+cancellationGetFD cancellation =
+ liftM fromIntegral $ {# call cancellation_get_fd #} cancellation
addfile ./gnomevfs/System/Gnome/VFS/Directory.chs
hunk ./gnomevfs/System/Gnome/VFS/Directory.chs 1
+-- GIMP Toolkit (GTK) Binding for Haskell: binding to libgnomevfs -*-haskell-*-
+--
+-- Author : Peter Gavin
+-- Created: 1-Apr-2007
+--
+-- Copyright (c) 2007 Peter Gavin
+--
+-- This library is free software; you can redistribute it and/or
+-- modify it under the terms of the GNU Library General Public
+-- License as published by the Free Software Foundation; either
+-- version 2 of the License, or (at your option) any later version.
+--
+-- This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+-- Library General Public License for more details.
+--
+-- | Maintainer : gtk...@li...
+-- Stability : alpha
+-- Portability : portable (depends on GHC)
+-- [_$_]
+-- Functions for creating, removing, and accessing directories and
+-- their contents.
+-- [_$_]
+module System.Gnome.VFS.Directory (
+
+-- * Types
+ DirectoryHandle,
+ DirectoryVisitOptions(..),
+ DirectoryVisitResult(..),
+ [_$_]
+-- * Directory Creation
+ makeDirectory,
+ makeDirectoryForURI,
+
+-- * Directory Removal
+ removeDirectory,
+ removeDirectoryFromURI,
+
+-- * Directory Access
+ directoryOpen,
+ directoryOpenFromURI,
+ directoryReadNext,
+ directoryClose,
+ directoryListLoad,
+
+-- * Directory Traversal
+ directoryVisit,
+ directoryVisitURI,
+ directoryVisitFiles,
+ directoryVisitFilesAtURI
+ [_$_]
+ ) where
+
+import Control.Exception ( assert
+ , bracket )
+import Control.Monad ( liftM )
+import System.Glib.GList ( GList()
+ , toGList
+ , readGList )
+import System.Glib.UTFString ( withUTFString
+ , peekUTFString
+ , newUTFString )
+import System.Glib.FFI
+{#import System.Gnome.VFS.FileInfo#}
+{#import System.Gnome.VFS.Types#}
+{#import System.Gnome.VFS.Marshal#}
+
+{# context lib = "gnomevfs" prefix = "gnome_vfs" #}
+
+-- | Create @textURI@ as a directory. Only succeeds if a file or
+-- directory does not already exist at @textURI@.
+makeDirectory :: TextURI -- ^ @textURI@ - String representation of the URI of the directory to create
+ -> [FilePermissions] -- ^ @perm@ - 'FilePermissions' for the newly created directory
+ -> IO ()
+makeDirectory textURI perm =
+ let cPerm = cFromFlags perm
+ in withUTFString textURI $ \cTextURI ->
+ voidResultMarshal $ {# call make_directory #} cTextURI cPerm
+
+-- | Create @uri@ as a directory. Only succeeds if a file or
+-- directory does not already exist at @uri@.
+makeDirectoryForURI :: URI -- ^ @uri@ - 'URI' of the directory to be created
+ -> [FilePermissions] -- ^ @perm@ - 'FilePermissions' for the newly created directory
+ -> IO ()
+makeDirectoryForURI uri perm =
+ let cPerm = cFromFlags perm
+ in voidResultMarshal $ {# call make_directory_for_uri #} uri cPerm
+
+-- | Remove the directory at @textURI@. The object at @textURI@ must be an empty directory.
+removeDirectory :: TextURI -- ^ @textURI@ - URI of the directory to be removed
+ -> IO ()
+removeDirectory textURI =
+ withUTFString textURI $ voidResultMarshal . {# call remove_directory #}
+
+-- | Remove the directory at @uri@. The object at @uri@ must be an empty directory.
+removeDirectoryFromURI :: URI -- ^ @uri@ - 'URI' of the directory to be removed
+ -> IO ()
+removeDirectoryFromURI uri =
+ voidResultMarshal $ {# call remove_directory_from_uri #} uri
+
+-- | Open directory textURI for reading. Returns a 'DirectoryHandle'
+-- which can be used to read directory entries one by one.
+directoryOpen :: TextURI -- ^ @textURI@ - String representation of the URI of the directory to open
+ -> [FileInfoOptions] -- ^ @fileInfoOptions@ - options for reading file information
+ -> IO DirectoryHandle -- ^ handle to the opened directory
+directoryOpen textURI fileInfoOptions =
+ let cFileInfoOptions = cFromFlags fileInfoOptions
+ in withUTFString textURI $ \cTextURI ->
+ newObjectResultMarshal DirectoryHandle $ \cHandlePtr ->
+ {# call directory_open #} (castPtr cHandlePtr) cTextURI cFileInfoOptions
+
+-- | Open directory textURI for reading. Returns a 'DirectoryHandle'
+-- which can be used to read directory entries one by one.
+directoryOpenFromURI :: URI -- ^ @uri@ - 'URI' of the directory to open
+ -> [FileInfoOptions] -- ^ @fileInfoOptions@ - options for reading file information
+ -> IO DirectoryHandle -- ^ handle to the opened directory
+directoryOpenFromURI uri fileInfoOptions =
+ let cFileInfoOptions = cFromFlags fileInfoOptions
+ in newObjectResultMarshal DirectoryHandle $ \cHandlePtr ->
+ {# call directory_open_from_uri #} (castPtr cHandlePtr) uri cFileInfoOptions
+
+-- | Read the next directory entry from a 'DirectoryHandle'.
+directoryReadNext :: DirectoryHandle -- ^ @handle@ - a directory handle
+ -> IO FileInfo -- ^ file information for the next directory entry
+directoryReadNext handle =
+ alloca $ \(cFileInfoPtr :: Ptr FileInfo) ->
+ genericResultMarshal ({# call directory_read_next #} handle $ castPtr cFileInfoPtr)
+ (peek cFileInfoPtr)
+ (return ())
+
+-- | Close a 'DirectoryHandle'.
+directoryClose :: DirectoryHandle -- ^ @handle@ - a directory handle
+ -> IO ()
+directoryClose handle =
+ voidResultMarshal $ {# call directory_close #} handle
+
+type CDirectoryVisitFunc = CString -- rel_path
+ -> Ptr FileInfo -- info
+ -> {# type gboolean #} -- recursing_will_loop
+ -> {# type gpointer #} -- user_data
+ -> Ptr {# type gboolean #} -- recurse
+ -> IO {# type gboolean #}
+directoryVisitCallbackMarshal :: DirectoryVisitCallback
+ -> IO {# type GnomeVFSDirectoryVisitFunc #}
+directoryVisitCallbackMarshal callback =
+ let cCallback :: CDirectoryVisitFunc
+ cCallback cRelPath cInfo cRecursingWillLoop cUserData cRecursePtr =
+ do relPath <- peekUTFString cRelPath
+ info <- peek cInfo
+ let recursingWillLoop = toBool cRecursingWillLoop
+ result <- callback relPath info recursingWillLoop
+ case result of
+ DirectoryVisitStop -> return $ fromBool False
+ DirectoryVisitContinue -> return $ fromBool True
+ DirectoryVisitRecurse -> do poke cRecursePtr $ fromBool True
+ return $ fromBool True
+ in makeDirectoryVisitFunc cCallback
+foreign import ccall safe "wrapper"
+ makeDirectoryVisitFunc :: CDirectoryVisitFunc
+ -> IO {# type GnomeVFSDirectoryVisitFunc #}
+
+type DirectoryVisit = [FileInfoOptions]
+ -> [DirectoryVisitOptions]
+ -> DirectoryVisitCallback
+ -> IO ()
+type CDirectoryVisit = {# type GnomeVFSFileInfoOptions #}
+ -> {# type GnomeVFSDirectoryVisitOptions #}
+ -> {# type GnomeVFSDirectoryVisitFunc #}
+ -> {# type gpointer #}
+ -> IO {# type GnomeVFSResult #}
+
+directoryVisitMarshal :: CDirectoryVisit
+ -> DirectoryVisit
+directoryVisitMarshal cVisitAction infoOptions visitOptions callback =
+ let cInfoOptions = cFromFlags infoOptions
+ cVisitOptions = cFromFlags visitOptions
+ in bracket (directoryVisitCallbackMarshal callback)
+ freeHaskellFunPtr
+ (\cDirectoryVisitFunc ->
+ voidResultMarshal $ cVisitAction cInfoOptions cVisitOptions cDirectoryVisitFunc nullPtr)
+
+-- | Visit each entry in a directory at a 'TextURI', calling a
+-- 'DirectoryVisitCallback' for each one.
+directoryVisit :: String -- ^ @textURI@ - string representation of the URI of the directory to visit
+ -> [FileInfoOptions] -- ^ @infoOptions@ - options for reading file information
+ -> [DirectoryVisitOptions] -- ^ @visitOptions@ - options for visiting the directory
+ -> DirectoryVisitCallback -- ^ @callback@ - a function to be called for each entry
+ -> IO ()
+directoryVisit textURI infoOptions visitOptions callback =
+ withUTFString textURI $ \cTextURI ->
+ directoryVisitMarshal ({# call directory_visit #} cTextURI) infoOptions visitOptions callback
+
+-- | Visit each entry in a directory at a 'URI', calling a
+-- 'DirectoryVisitCallback' for each one.
+directoryVisitURI :: URI -- ^ @uri@ - the URI of the directory to visit
+ -> [FileInfoOptions] -- ^ @infoOptions@ - options for reading file information
+ -> [DirectoryVisitOptions] -- ^ @visitOptions@ - options for visiting the directory
+ -> DirectoryVisitCallback -- ^ @callback@ - a function to be called for each entry
+ -> IO ()
+directoryVisitURI uri =
+ directoryVisitMarshal ({# call directory_visit_uri #} uri)
+
+-- | Visit each file in a list contained with a directory at a
+-- 'TextURI', calling a 'DirectoryVisitCallback' for each one.
+directoryVisitFiles :: TextURI -- ^ @textURI@ - string representation of the URI of the directory to visit
+ -> [String] -- ^ @files@ - the files contained in @textURI@ to be visited
+ -> [FileInfoOptions] -- ^ @infoOptions@ - options for reading file information
+ -> [DirectoryVisitOptions] -- ^ @visitOptions@ - options for visiting the directory
+ -> DirectoryVisitCallback -- ^ @callback@ - a function to be called for each entry
+ -> IO ()
+directoryVisitFiles textURI files infoOptions visitOptions callback =
+ do cFiles <- mapM newUTFString files >>= toGList
+ withUTFString textURI $ \cTextURI ->
+ directoryVisitMarshal ({# call directory_visit_files #} cTextURI cFiles) infoOptions visitOptions callback
+
+-- | Visit each file in a list contained with a directory at a
+-- 'URI', calling a 'DirectoryVisitCallback' for each one.
+directoryVisitFilesAtURI :: URI -- ^ @uri@ - the 'URI' of the directory to visit
+ -> [String] -- ^ @files@ - the files contained in @textURI@ to be visited
+ -> [FileInfoOptions] -- ^ @infoOptions@ - options for reading file information
+ -> [DirectoryVisitOptions] -- ^ @visitOptions@ - options for visiting the directory
+ -> DirectoryVisitCallback -- ^ @callback@ - a function to be called for each entry
+ -> IO ()
+directoryVisitFilesAtURI uri files infoOptions visitOptions callback =
+ do cFiles <- mapM newUTFString files >>= toGList
+ directoryVisitMarshal ({# call directory_visit_files_at_uri #} uri cFiles) infoOptions visitOptions callback
+
+-- | Create a list of 'FileInfo' objects representing each entry in the
+-- directory at @textURI@, using options @options@.
+directoryListLoad :: TextURI -- ^ @textURI@ - String representation of the URI of the directory to load
+ -> [FileInfoOptions] -- ^ @options@ - options for reading file information
+ -> IO [FileInfo] -- ^ the entries contined in the directory
+directoryListLoad textURI options =
+ let cOptions = cFromFlags options
+ in withUTFString textURI $ \cTextURI ->
+ alloca $ \cListPtr ->
+ genericResultMarshal ({# call directory_list_load #} cListPtr cTextURI cOptions)
+ (peek cListPtr >>= readGList >>= mapM peek)
+ (do cList <- peek cListPtr
+ assert (cList == nullPtr) $ return ())
addfile ./gnomevfs/System/Gnome/VFS/Drive.chs
hunk ./gnomevfs/System/Gnome/VFS/Drive.chs 1
+-- GIMP Toolkit (GTK) Binding for Haskell: binding to libgnomevfs -*-haskell-*-
+--
+-- Author : Peter Gavin
+-- Created: 1-Apr-2007
+--
+-- Copyright (c) 2007 Peter Gavin
+--
+-- This library is free software; you can redistribute it and/or
+-- modify it under the terms of the GNU Library General Public
+-- License as published by the Free Software Foundation; either
+-- version 2 of the License, or (at your option) any later version.
+--
+-- This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+-- Library General Public License for more details.
+--
+-- | Maintainer : gtk...@li...
+-- Stability : alpha
+-- Portability : portable (depends on GHC)
+module System.Gnome.VFS.Drive (
+
+-- * Types
+ -- | A container for 'Volume's.
+ Drive,
+ DriveClass,
+ DeviceType,
+
+-- * Type Conversion
+ castToDrive,
+
+-- * Drive Comparison
+ driveCompare,
+
+-- * Drive Properties
+ driveGetActivationURI,
+ driveGetDevicePath,
+ driveGetDeviceType,
+ driveGetDisplayName,
+ driveGetHalUDI,
+ driveGetIcon,
+ driveGetID,
+
+-- * Drive State
+ driveIsConnected,
+ driveIsMounted,
+ driveIsUserVisible,
+ driveGetMountedVolumes,
+
+-- * Drive Operations
+ driveEject,
+ driveMount,
+ [_$_]
+-- * Drive Signals
+ onDriveVolumeMounted,
+ afterDriveVolumeMounted,
+ onDriveVolumePreUnmount,
+ afterDriveVolumePreUnmount,
+ onDriveVolumeUnmounted,
+ afterDriveVolumeUnmounted
+ [_$_]
+ ) where
+
+import Control.Exception
+import Control.Monad ( liftM )
+import System.Glib.UTFString
+import System.Glib.FFI
+import System.Glib.GList ( fromGList )
+{#import System.Glib.Signals#}
+{#import System.Gnome.VFS.Marshal#}
+{#import System.Gnome.VFS.Types#}
+{#import System.Gnome.VFS.Signals#}
+
+{# context lib = "gnomevfs" prefix = "gnome_vfs" #}
+
+-- | Compares two 'DriveClass' objects @a@ and @b@. Two 'DriveClass'
+-- objects referring to different drives are guaranteed to not
+-- return 'EQ' when comparing them. If they refer to the same drive 'EQ'
+-- is returned.
+-- [_$_]
+-- The resulting gint should be used to determine the order in which
+-- @a@ and @b@ are displayed in graphical user interfaces.
+-- [_$_]
+-- The comparison algorithm first of all peeks the device type of
+-- @a@ and @b@, they will be sorted in the following order:
+-- [_$_]
+-- * Magnetic and opto-magnetic drives (ZIP, floppy)
+-- [_$_]
+-- * Optical drives (CD, DVD)
+-- [_$_]
+-- * External drives (USB sticks, music players)
+-- [_$_]
+-- * Mounted hard disks
+-- [_$_]
+-- * Other drives
+-- [_$_]
+-- Afterwards, the display name of @a@ and @b@ is compared using a
+-- locale-sensitive sorting algorithm.
+-- [_$_]
+-- If two drives have the same display name, their unique ID is
+-- compared which can be queried using 'driveGetID'.
+driveCompare :: DriveClass drive =>
+ drive -- ^ @a@ - the first drive
+ -> drive -- ^ @b@ - the second drive
+ -> IO Ordering -- ^ the ordering relationship between the drives
+driveCompare a b =
+ do result <- liftM fromIntegral $ {# call drive_compare #} (castToDrive a) (castToDrive b)
+ let ordering | result < 0 = LT
+ | result > 0 = GT
+ | otherwise = EQ
+ return ordering
+
+-- | If drive has associated 'Volume' objects, all of them will
+-- be unmounted by calling 'volumeUnmount' for each volume in
+-- 'driveGetMountedVolumes', except for the last one, for which
+-- 'volumeEject' is called to ensure that the drive's media is
+-- ejected.
+driveEject :: DriveClass drive =>
+ drive -- ^ @drive@ - the drive to be ejected
+ -> VolumeOpSuccessCallback -- ^ @successCallback@ - the
+ -- action to be performed on
+ -- successful ejection
+ -> VolumeOpFailureCallback -- ^ @failureCallback@ - the
+ -- action to be performed on
+ -- failure
+ -> IO ()
+driveEject drive successCallback failureCallback =
+ do cCallback <- volumeOpCallbackMarshal successCallback failureCallback
+ {# call drive_eject #} (castToDrive drive) cCallback $ castFunPtrToPtr cCallback
+
+marshalString cAction drive =
+ cAction (castToDrive drive) >>= readUTFString
+marshalMaybeString cAction drive =
+ cAction (castToDrive drive) >>= (maybePeek readUTFString)
+
+-- | Returns the activation URI of @drive@.
+-- [_$_]
+-- The returned URI usually refers to a valid location. You can
+-- check the validity of the location by calling 'uriFromString'
+-- with the URI, and checking whether the return value is not
+-- 'Nothing'.
+driveGetActivationURI :: DriveClass drive
+ => drive -- ^ @drive@ - the drive object to query
+ -> IO String -- ^ the drive's activation URI
+driveGetActivationURI =
+ marshalString {# call drive_get_activation_uri #}
+
+-- | Returns the device path of a 'Drive' object.
+-- [_$_]
+-- For HAL drives, this returns the value of the drive's
+-- @block.device@ key. For UNIX mounts, it returns the @mntent@'s
+-- @mnt_fsname@ entry.
+-- [_$_]
+-- Otherwise, it returns 'Nothing'.
+driveGetDevicePath :: DriveClass drive =>
+ drive -- ^ @drive@ - the drive object to query
+ -> IO (Maybe String) -- ^ the drive's device path
+driveGetDevicePath =
+ marshalMaybeString {# call drive_get_device_path #}
+
+-- | Returns the 'DeviceType' of a 'Drive' object.
+driveGetDeviceType :: DriveClass drive =>
+ drive -- ^ @drive@ - the drive object to query
+ -> IO DeviceType -- ^ the drive's device type
+driveGetDeviceType drive =
+ liftM cToEnum $ {# call drive_get_device_type #} (castToDrive drive)
+
+-- | Returns the display name of a 'Drive' object.
+driveGetDisplayName :: DriveClass drive =>
+ drive -- ^ @drive@ - the drive object to query
+ -> IO String -- ^ the drive's display name
+driveGetDisplayName =
+ marshalString {# call drive_get_display_name #}
+
+-- | Returns the HAL UDI of a 'Drive' object.
+-- [_$_]
+-- For HAL drives, this matches the value of the @info.udi@ key,
+-- for other drives it is 'Nothing'.
+driveGetHalUDI :: DriveClass drive =>
+ drive -- ^ @drive@ - the drive object to query
+ -> IO (Maybe String) -- ^ the drive's HAL UDI
+driveGetHalUDI =
+ marshalMaybeString {# call drive_get_hal_udi #}
+
+-- | Returns the icon filename for a 'Drive' object.
+driveGetIcon :: DriveClass drive =>
+ drive -- ^ @drive@ - a drive object
+ -> IO FilePath -- ^ the icon that should be used for this drive
+driveGetIcon =
+ marshalString {# call drive_get_icon #}
+
+-- | Returns a unique identifier for a 'Drive' object.
+driveGetID :: DriveClass drive =>
+ drive -- ^ @drive@ - a drive object
+ -> IO Word -- ^ a unique identifier for the drive
+driveGetID drive =
+ liftM fromIntegral $ {# call drive_get_id #} (castToDrive drive)
+
+-- | Returns a list of mounted volumes for a 'Drive' object.
+driveGetMountedVolumes :: DriveClass drive =>
+ drive -- ^ @drive@ - a drive object
+ -> IO [Volume] -- ^ the 'Volume's currently
+ -- mounted on the drive
+driveGetMountedVolumes drive =
+ {# call drive_get_mounted_volumes #} (castToDrive drive) >>=
+ fromGList >>=
+ mapM newVolume
+
+marshalBool cAction drive =
+ liftM toBool $ cAction (castToDrive drive)
+
+-- | Returns a 'Bool' for whether a drive is connected.
+driveIsConnected :: DriveClass drive =>
+ drive -- ^ @drive@ - a drive object
+ -> IO Bool -- ^ 'True' if the drive is connected,
+ -- 'False' otherwise
+driveIsConnected =
+ marshalBool {# call drive_is_connected #}
+
+-- | Returns a 'Bool' for whether a drive is mounted.
+driveIsMounted :: DriveClass drive =>
+ drive -- ^ @drive@ - a drive object
+ -> IO Bool -- ^ 'True' if the drive is mounted,
+ -- 'False' otherwise
+driveIsMounted =
+ marshalBool {# call drive_is_mounted #}
+
+-- | Returns a 'Bool' for whether a drive is user-visible. This should
+-- be used by applications to determine whether the drive should be
+-- listed in user interfaces listing available drives.
+driveIsUserVisible :: DriveClass drive =>
+ drive -- ^ @drive@ - a drive object
+ -> IO Bool -- ^ 'True' if the drive is
+ -- user-visible, 'False' otherwise
+driveIsUserVisible =
+ marshalBool {# call drive_is_user_visible #}
+
+-- | Mounts a 'Drive' object.
+driveMount :: DriveClass drive =>
+ drive -- ^ @drive@ - a drive object
+ -> VolumeOpSuccessCallback -- ^ @successCallback@ - the
+ -- action to be performed on
+ -- successful mount
+ -> VolumeOpFailureCallback -- ^ @failureCallback@ - the
+ -- action to be performed on
+ -- failure
+ -> IO ()
+driveMount drive successCallback failureCallback =
+ do cCallback <- volumeOpCallbackMarshal successCallback failureCallback
+ {# call drive_eject #} (castToDrive drive) cCallback $ castFunPtrToPtr cCallback
+
+onDriveVolumeMounted,
+ afterDriveVolumeMounted,
+ onDriveVolumePreUnmount,
+ afterDriveVolumePreUnmount,
+ onDriveVolumeUnmounted,
+ afterDriveVolumeUnmounted
+ :: (DriveClass drive, VolumeClass volume) =>
+ drive
+ -> (volume -> IO ())
+ -> IO (ConnectId drive)
+
+onDriveVolumeMounted = connect_OBJECT__NONE "volume-mounted" False
+afterDriveVolumeMounted = connect_OBJECT__NONE "volume-mounted" True
+
+onDriveVolumePreUnmount = connect_OBJECT__NONE "volume-pre-unmount" False
+afterDriveVolumePreUnmount = connect_OBJECT__NONE "volume-pre-unmount" True
+
+onDriveVolumeUnmounted = connect_OBJECT__NONE "volume-unmounted" False
+afterDriveVolumeUnmounted = connect_OBJECT__NONE "volume-unmounted" True
addfile ./gnomevfs/System/Gnome/VFS/Error.hs
hunk ./gnomevfs/System/Gnome/VFS/Error.hs 1
+-- GIMP Toolkit (GTK) Binding for Haskell: binding to libgnomevfs -*-haskell-*-
+--
+-- Author : Peter Gavin
+-- Created: 1-Apr-2007
+--
+-- Copyright (c) 2007 Peter Gavin
+--
+-- This library is free software; you can redistribute it and/or
+-- modify it under the terms of the GNU Library General Public
+-- License as published by the Free Software Foundation; either
+-- version 2 of the License, or (at your option) any later version.
+--
+-- This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+-- Library General Public License for more details.
+--
+-- | Maintainer : gtk...@li...
+-- Stability : alpha
+-- Portability : portable (depends on GHC)
+module System.Gnome.VFS.Error (
+ [_$_]
+ Error(..),
+ [_$_]
+ error,
+ errors,
+ eofErrors,
+ [_$_]
+ ) where
+
+import Control.Monad (join)
+import qualified Control.Exception as E
+import Data.Dynamic
+import System.Gnome.VFS.Types
+import Prelude hiding (error)
+
+error :: Result
+ -> IO a
+error = E.throwDyn . Error
+
+errors :: E.Exception
+ -> Maybe Error
+errors =
+ join . (fmap fromDynamic) . E.dynExceptions
+
+eofErrors :: E.Exception
+ -> Maybe Error
+eofErrors exception =
+ let vfsError = errors exception in
+ case vfsError of
+ Just (Error ErrorEof) -> vfsError
+ _ -> Nothing
addfile ./gnomevfs/System/Gnome/VFS/FileInfo.chs
hunk ./gnomevfs/System/Gnome/VFS/FileInfo.chs 1
+-- GIMP Toolkit (GTK) Binding for Haskell: binding to libgnomevfs -*-haskell-*-
+--
+-- Author : Peter Gavin
+-- Created: 1-Apr-2007
+--
+-- Copyright (c) 2007 Peter Gavin
+--
+-- This library is free software; you can redistribute it and/or
+-- modify it under the terms of the GNU Library General Public
+-- License as published by the Free Software Foundation; either
+-- version 2 of the License, or (at your option) any later version.
+--
+-- This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+-- Library General Public License for more details.
+--
+-- | Maintainer : gtk...@li...
+-- Stability : alpha
+-- Portability : portable (depends on GHC)
+module System.Gnome.VFS.FileInfo (
+ [_$_]
+ -- * Types
+ FileInfo(..),
+ FileFlags(..),
+ FileType(..),
+ InodeNumber,
+ IDs,
+ [_$_]
+ ) where
+
+import Control.Monad (liftM)
+import Data.Maybe (catMaybes)
+import System.Glib.Flags
+import System.Glib.FFI
+import System.Glib.UTFString
+{#import System.Gnome.VFS.Marshal#}
+{#import System.Gnome.VFS.Types#}
+import System.Posix.Types (DeviceID, EpochTime)
+
+{# context lib = "gnomevfs" prefix = "gnome_vfs" #}
+
+{- typedef struct {
+ - char *name;
+ - GnomeVFSFileInfoFields valid_fields;
+ - GnomeVFSFileType type;
+ - GnomeVFSFilePermissions permissions;
+ - GnomeVFSFileFlags flags;
+ - dev_t device;
+ - GnomeVFSInodeNumber inode;
+ - guint link_count;
+ - guint uid;
+ - guint gid;
+ - GnomeVFSFileSize size;
+ - GnomeVFSFileSize block_count;
+ - guint io_block_size;
+ - time_t atime;
+ - time_t mtime;
+ - time_t ctime;
+ - char *symlink_name;
+ - char *mime_type;
+ - guint refcount;
+ - GnomeVFSACL *acl;
+ - char* selinux_context;
+ - } GnomeVFSFileInfo;
+ -}
+
+instance Storable FileInfo where
+ sizeOf _ = {# sizeof GnomeVFSFileInfo #}
+ alignment _ = alignment (undefined :: CString)
+ peek ptr =
+ do name <- {# get GnomeVFSFileInfo->name #} ptr >>= maybePeek peekUTFString
+ [_$_]
+ validFields <- liftM cToFlags $ {# get GnomeVFSFileInfo->valid_fields #} ptr
+ [_$_]
+ let maybeField field result = if elem field validFields
+ then liftM Just result
+ else return Nothing
+ [_$_]
+ fileType <- maybeField FileInfoFieldsType $
+ liftM cToEnum $ cFileInfoGetType ptr
+ permissions <- maybeField FileInfoFieldsPermissions $
+ liftM cToFlags $ {# get GnomeVFSFileInfo->permissions #} ptr
+ fileFlags <- maybeField FileInfoFieldsFlags $
+ liftM cToFlags $ {# get GnomeVFSFileInfo->flags #} ptr
+ [_$_]
+ device <- maybeField FileInfoFieldsDevice $
+ liftM cToEnum $ {# get GnomeVFSFileInfo->device #} ptr
+ [_$_]
+ inode <- maybeField FileInfoFieldsInode $
+ liftM fromIntegral $ cFileInfoGetInode ptr
+ linkCount <- maybeField FileInfoFieldsLinkCount $
+ liftM fromIntegral $ {# get GnomeVFSFileInfo->link_count #} ptr
+ [_$_]
+ ids <- maybeField FileInfoFieldsIds $
+ do uid <- liftM fromIntegral $ {# get GnomeVFSFileInfo->uid #} ptr
+ gid <- liftM fromIntegral $ {# get GnomeVFSFileInfo->gid #} ptr
+ return $ (uid, gid)
+ [_$_]
+ size <- maybeField FileInfoFieldsSize $
+ liftM fromIntegral $ cFileInfoGetSize ptr
+ blockCount <- maybeField FileInfoFieldsBlockCount $
+ liftM fromIntegral $ {# get GnomeVFSFileInfo->block_count #} ptr
+ [_$_]
+ ioBlockSize <- maybeField FileInfoFieldsIoBlockSize $
+ liftM fromIntegral $ {# get GnomeVFSFileInfo->io_block_size #} ptr
+ [_$_]
+ aTime <- maybeField FileInfoFieldsAtime $
+ liftM cToEnum $ {# get GnomeVFSFileInfo->atime #} ptr
+ mTime <- maybeField FileInfoFieldsMtime $
+ liftM cToEnum $ {# get GnomeVFSFileInfo->mtime #} ptr
+ cTime <- maybeField FileInfoFieldsCtime $
+ liftM cToEnum $ {# get GnomeVFSFileInfo->ctime #} ptr
+ symlinkName <- maybeField FileInfoFieldsSymlinkName $
+ {# get GnomeVFSFileInfo->symlink_name #} ptr >>= peekUTFString
+ mimeType <- maybeField FileInfoFieldsMimeType $
+ {# call file_info_get_mime_type #} (castPtr ptr) >>= peekUTFString
+ return $ FileInfo name
+ fileType
+ permissions
+ fileFlags
+ device
+ inode
+ linkCount
+ ids
+ size
+ blockCount
+ ioBlockSize
+ aTime
+ mTime
+ cTime
+ symlinkName
+ mimeType
+ poke ptr (FileInfo name
+ fileType
+ permissions
+ fileFlags
+ device
+ inode
+ linkCount
+ ids
+ size
+ blockCount
+ ioBlockSize
+ aTime
+ mTime
+ cTime
+ symlinkName
+ mimeType) =
+ do let marshaller :: FileInfoFields
+ -> Maybe a
+ -> b
+ -> (a -> IO b)
+ -> (Ptr FileInfo -> b -> IO ())
+ -> IO (Maybe FileInfoFields)
+ marshaller field Nothing dflt _ action =
+ do action ptr dflt
+ return Nothing
+ marshaller field (Just value) _ cast action =
+ do cast value >>= action ptr
+ return $ Just field
+ [_$_]
+ case name of
+ Just name' -> newUTFString name' >>= {# set GnomeVFSFileInfo->name #} ptr
+ Nothing -> return ()
+ [_$_]
+ validFields <- liftM catMaybes $ sequence $ [_$_]
+ [ marshaller FileInfoFieldsType
+ fileType
+ ...
[truncated message content] |
