diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,504 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 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 + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! + + diff --git a/Gtk2HsSetup.hs b/Gtk2HsSetup.hs new file mode 100644 --- /dev/null +++ b/Gtk2HsSetup.hs @@ -0,0 +1,486 @@ +{-# LANGUAGE CPP #-} + +#define CABAL_VERSION_ENCODE(major, minor, micro) ( \ + ((major) * 10000) \ + + ((minor) * 100) \ + + ((micro) * 1)) + +#define CABAL_VERSION_CHECK(major,minor,micro) \ + (CABAL_VERSION >= CABAL_VERSION_ENCODE(major,minor,micro)) + +-- now, this is bad, but Cabal doesn't seem to actually pass any information about +-- its version to CPP, so guess the version depending on the version of GHC +#ifdef CABAL_VERSION_MINOR +#ifndef CABAL_VERSION_MAJOR +#define CABAL_VERSION_MAJOR 1 +#endif +#ifndef CABAL_VERSION_MICRO +#define CABAL_VERSION_MICRO 0 +#endif +#define CABAL_VERSION CABAL_VERSION_ENCODE( \ + CABAL_VERSION_MAJOR, \ + CABAL_VERSION_MINOR, \ + CABAL_VERSION_MICRO) +#else +#warning Setup.hs is guessing the version of Cabal. If compilation of Setup.hs fails use -DCABAL_VERSION_MINOR=x for Cabal version 1.x.0 when building (prefixed by --ghc-option= when using the 'cabal' command) +#if (__GLASGOW_HASKELL__ >= 612) +#define CABAL_VERSION CABAL_VERSION_ENCODE(1,8,0) +#else +#define CABAL_VERSION CABAL_VERSION_ENCODE(1,6,0) +#endif +#endif + +-- | Build a Gtk2hs package. +-- +module Gtk2HsSetup ( gtk2hsUserHooks, getPkgConfigPackages ) where + +import Distribution.Simple +import Distribution.Simple.PreProcess +import Distribution.InstalledPackageInfo ( importDirs, + showInstalledPackageInfo, + libraryDirs, + extraLibraries, + extraGHCiLibraries ) +import Distribution.Simple.PackageIndex ( +#if CABAL_VERSION_CHECK(1,8,0) + lookupInstalledPackageId +#else + lookupPackageId +#endif + ) +import Distribution.PackageDescription as PD ( PackageDescription(..), + updatePackageDescription, + BuildInfo(..), + emptyBuildInfo, allBuildInfo, + Library(..), + libModules, hasLibs) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), + InstallDirs(..), +#if CABAL_VERSION_CHECK(1,8,0) + componentPackageDeps, +#else + packageDeps, +#endif + absoluteInstallDirs) +import Distribution.Simple.Compiler ( Compiler(..) ) +import Distribution.Simple.Program ( + Program(..), ConfiguredProgram(..), + rawSystemProgramConf, rawSystemProgramStdoutConf, + c2hsProgram, pkgConfigProgram, requireProgram, ghcPkgProgram, + simpleProgram, lookupProgram, rawSystemProgramStdout, ProgArg) +import Distribution.ModuleName ( ModuleName, components, toFilePath ) +import Distribution.Simple.Utils +import Distribution.Simple.Setup (CopyFlags(..), InstallFlags(..), CopyDest(..), + defaultCopyFlags, ConfigFlags(configVerbosity), + fromFlag, toFlag, RegisterFlags(..), flagToMaybe, + fromFlagOrDefault, defaultRegisterFlags) +import Distribution.Simple.BuildPaths ( autogenModulesDir ) +import Distribution.Simple.Install ( install ) +#if CABAL_VERSION_CHECK(1,8,0) +import Distribution.Simple.Register ( generateRegistrationInfo, registerPackage ) +#else +import qualified Distribution.Simple.Register as Register ( register ) +#endif +import Distribution.Text ( simpleParse, display ) +import System.FilePath +import System.Directory ( doesFileExist ) +import Distribution.Version (Version(..)) +import Distribution.Verbosity +import Control.Monad (when, unless, filterM) +import Data.Maybe ( isJust, isNothing, fromMaybe, maybeToList ) +import Data.List (isPrefixOf, isSuffixOf, nub) +import Data.Char (isAlpha) +import qualified Data.Map as M +import qualified Data.Set as S + +import Control.Applicative ((<$>)) +import System.Directory (getDirectoryContents, doesDirectoryExist) + +-- the name of the c2hs pre-compiled header file +precompFile = "precompchs.bin" + +gtk2hsUserHooks = simpleUserHooks { + hookedPrograms = [typeGenProgram, signalGenProgram, c2hsLocal], + hookedPreProcessors = [("chs", ourC2hs)], + confHook = \pd cf -> + confHook simpleUserHooks pd cf >>= return . adjustLocalBuildInfo, + postConf = \args cf pd lbi -> do + genSynthezisedFiles (fromFlag (configVerbosity cf)) pd lbi + postConf simpleUserHooks args cf pd lbi, + buildHook = \pd lbi uh bf -> fixDeps pd >>= \pd -> + (buildHook simpleUserHooks) pd lbi uh bf, + copyHook = \pd lbi uh flags -> (copyHook simpleUserHooks) pd lbi uh flags >> + installCHI pd lbi (fromFlag (copyVerbosity flags)) (fromFlag (copyDest flags)), + instHook = \pd lbi uh flags -> +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + installHook pd lbi uh flags >> + installCHI pd lbi (fromFlag (installVerbosity flags)) NoCopyDest, + regHook = registerHook +#else + instHook simpleUserHooks pd lbi uh flags >> + installCHI pd lbi (fromFlag (installVerbosity flags)) NoCopyDest +#endif + } + +------------------------------------------------------------------------------ +-- Lots of stuff for windows ghci support +------------------------------------------------------------------------------ + +getDlls :: [FilePath] -> IO [FilePath] +getDlls dirs = filter ((== ".dll") . takeExtension) . concat <$> + mapM getDirectoryContents dirs + +fixLibs :: [FilePath] -> [String] -> [String] +fixLibs dlls = concatMap $ \ lib -> + case filter (("lib" ++ lib) `isPrefixOf`) dlls of + dll:_ -> [dropExtension dll] + _ -> if lib == "z" then [] else [lib] + +-- The following code is a big copy-and-paste job from the sources of +-- Cabal 1.8 just to be able to fix a field in the package file. Yuck. + +#if CABAL_VERSION_CHECK(1,8,0) + +installHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> InstallFlags -> IO () +installHook pkg_descr localbuildinfo _ flags = do + let copyFlags = defaultCopyFlags { + copyDistPref = installDistPref flags, + copyDest = toFlag NoCopyDest, + copyVerbosity = installVerbosity flags + } + install pkg_descr localbuildinfo copyFlags + let registerFlags = defaultRegisterFlags { + regDistPref = installDistPref flags, + regInPlace = installInPlace flags, + regPackageDB = installPackageDB flags, + regVerbosity = installVerbosity flags + } + when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags + +registerHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> RegisterFlags -> IO () +registerHook pkg_descr localbuildinfo _ flags = + if hasLibs pkg_descr + then register pkg_descr localbuildinfo flags + else setupMessage verbosity + "Package contains no library to register:" (packageId pkg_descr) + where verbosity = fromFlag (regVerbosity flags) + +register :: PackageDescription -> LocalBuildInfo + -> RegisterFlags -- ^Install in the user's database?; verbose + -> IO () +register pkg@PackageDescription { library = Just lib } + lbi@LocalBuildInfo { libraryConfig = Just clbi } regFlags + = do + + installedPkgInfoRaw <- generateRegistrationInfo + verbosity pkg lib lbi clbi inplace distPref + + dllsInScope <- getSearchPath >>= (filterM doesDirectoryExist) >>= getDlls + let libs = fixLibs dllsInScope (extraLibraries installedPkgInfoRaw) + installedPkgInfo = installedPkgInfoRaw { + extraGHCiLibraries = libs } + + -- Three different modes: + case () of + _ | modeGenerateRegFile -> die "Generate Reg File not supported" + | modeGenerateRegScript -> die "Generate Reg Script not supported" + | otherwise -> registerPackage verbosity + installedPkgInfo pkg lbi inplace packageDb + + where + modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) + modeGenerateRegScript = fromFlag (regGenScript regFlags) + inplace = fromFlag (regInPlace regFlags) + packageDb = case flagToMaybe (regPackageDB regFlags) of + Just db -> db + Nothing -> registrationPackageDB (withPackageDB lbi) + distPref = fromFlag (regDistPref regFlags) + verbosity = fromFlag (regVerbosity regFlags) + +register _ _ regFlags = notice verbosity "No package to register" + where + verbosity = fromFlag (regVerbosity regFlags) + +#else +installHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> InstallFlags -> IO () +installHook pkg_descr localbuildinfo _ flags = do + let copyFlags = defaultCopyFlags { + copyDistPref = installDistPref flags, + copyInPlace = installInPlace flags, + copyUseWrapper = installUseWrapper flags, + copyDest = toFlag NoCopyDest, + copyVerbosity = installVerbosity flags + } + install pkg_descr localbuildinfo copyFlags + let registerFlags = defaultRegisterFlags { + regDistPref = installDistPref flags, + regInPlace = installInPlace flags, + regPackageDB = installPackageDB flags, + regVerbosity = installVerbosity flags + } + when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags + +registerHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> RegisterFlags -> IO () +registerHook pkg_descr localbuildinfo _ flags = + if hasLibs pkg_descr + then register pkg_descr localbuildinfo flags + else setupMessage verbosity + "Package contains no library to register:" (packageId pkg_descr) + where verbosity = fromFlag (regVerbosity flags) + +register :: PackageDescription -> LocalBuildInfo + -> RegisterFlags -- ^Install in the user's database?; verbose + -> IO () +register pkg_descr lbi regFlags = do + let verbosity = fromFlag (regVerbosity regFlags) + warn verbosity "Cannot register ghci libraries with Cabal 1.6 (need 1.8)." + Register.register pkg_descr lbi regFlags + +#endif + +------------------------------------------------------------------------------ +-- This is a hack for Cabal-1.8, It is not needed in Cabal-1.9.1 or later +------------------------------------------------------------------------------ + +adjustLocalBuildInfo :: LocalBuildInfo -> LocalBuildInfo +adjustLocalBuildInfo lbi = + let extra = (Just libBi, []) + libBi = emptyBuildInfo { includeDirs = [ autogenModulesDir lbi + , buildDir lbi ] } + in lbi { localPkgDescr = updatePackageDescription extra (localPkgDescr lbi) } + +------------------------------------------------------------------------------ +-- Processing .chs files with our local c2hs. +------------------------------------------------------------------------------ + +ourC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor +ourC2hs bi lbi = PreProcessor { + platformIndependent = False, + runPreProcessor = runC2HS bi lbi +} + +runC2HS :: BuildInfo -> LocalBuildInfo -> + (FilePath, FilePath) -> (FilePath, FilePath) -> Verbosity -> IO () +runC2HS bi lbi (inDir, inFile) (outDir, outFile) verbosity = do + -- have the header file name if we don't have the precompiled header yet + header <- case lookup "x-c2hs-header" (customFieldsBI bi) of + Just h -> return h + Nothing -> die ("Need x-c2hs-Header definition in the .cabal Library section "++ + "that sets the C header file to process .chs.pp files.") + + -- c2hs will output files in out dir, removing any leading path of the input file. + -- Thus, append the dir of the input file to the output dir. + let (outFileDir, newOutFile) = splitFileName outFile + let newOutDir = outDir outFileDir + -- additional .chi files might be needed that other packages have installed; + -- we assume that these are installed in the same place as .hi files + let chiDirs = [ dir | +#if CABAL_VERSION_CHECK(1,8,0) + ipi <- maybe [] (map fst . componentPackageDeps) (libraryConfig lbi), + dir <- maybe [] importDirs (lookupInstalledPackageId (installedPkgs lbi) ipi) ] +#else + ipi <- packageDeps lbi, + dir <- maybe [] importDirs (lookupPackageId (installedPkgs lbi) ipi) ] +#endif + rawSystemProgramConf verbosity c2hsLocal (withPrograms lbi) $ + map ("--include=" ++) (outDir:chiDirs) + ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi] + ++ ["--output-dir=" ++ newOutDir, + "--output=" ++ newOutFile, + "--precomp=" ++ buildDir lbi precompFile, + header, inDir inFile] + +getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] +getCppOptions bi lbi + = nub $ + ["-I" ++ dir | dir <- PD.includeDirs bi] + ++ [opt | opt@('-':c:_) <- (PD.cppOptions bi ++ PD.ccOptions bi), c `elem` "DIU"] + +installCHI :: PackageDescription -- ^information from the .cabal file + -> LocalBuildInfo -- ^information from the configure step + -> Verbosity -> CopyDest -- ^flags sent to copy or install + -> IO () +installCHI pkg@PD.PackageDescription { library = Just lib } lbi verbosity copydest = do + let InstallDirs { libdir = libPref } = absoluteInstallDirs pkg lbi copydest + -- cannot use the recommended 'findModuleFiles' since it fails if there exists + -- a modules that does not have a .chi file + mFiles <- mapM (findFileWithExtension' ["chi"] [buildDir lbi]) + (map toFilePath +#if CABAL_VERSION_CHECK(1,8,0) + (PD.libModules lib) +#else + (PD.libModules pkg) +#endif + ) + let files = [ f | Just f <- mFiles ] +#if CABAL_VERSION_CHECK(1,8,0) + installOrdinaryFiles verbosity libPref files +#else + copyFiles verbosity libPref files +#endif + + +installCHI _ _ _ _ = return () + +------------------------------------------------------------------------------ +-- Generating the type hierarchy and signal callback .hs files. +------------------------------------------------------------------------------ + +typeGenProgram :: Program +typeGenProgram = (simpleProgram "gtk2hsTypeGen") + +signalGenProgram :: Program +signalGenProgram = (simpleProgram "gtk2hsHookGenerator") + +c2hsLocal :: Program +c2hsLocal = (simpleProgram "gtk2hsC2hs") + +genSynthezisedFiles :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () +genSynthezisedFiles verb pd lbi = do + + cPkgs <- getPkgConfigPackages verb lbi pd + + let xList = maybe [] (customFieldsBI . libBuildInfo) (library pd) + ++customFieldsPD pd + typeOpts :: String -> [ProgArg] + typeOpts tag = concat [ map (\val -> '-':'-':drop (length tag) field++'=':val) (words content) + | (field,content) <- xList, + tag `isPrefixOf` field, + field /= (tag++"file")] + ++ [ "--tag=" ++ tag + | PackageIdentifier name (Version (major:minor:_) _) <- cPkgs + , let name' = filter isAlpha (display name) + , tag <- name' + : [ name' ++ "-" ++ show major ++ "." ++ show digit + | digit <- [0,2..minor] ] + ] + + signalsOpts :: [ProgArg] + signalsOpts = concat [ map (\val -> '-':'-':drop 10 field++'=':val) (words content) + | (field,content) <- xList, + "x-signals-" `isPrefixOf` field, + field /= "x-signals-file"] + + genFile :: Program -> [ProgArg] -> FilePath -> IO () + genFile prog args outFile = do + res <- rawSystemProgramStdoutConf verb prog (withPrograms lbi) args + rewriteFile outFile res + + (flip mapM_) (filter (\(tag,_) -> "x-types-" `isPrefixOf` tag && "file" `isSuffixOf` tag) xList) $ + \(fileTag, f) -> do + let tag = reverse (drop 4 (reverse fileTag)) + info verb ("Ensuring that class hierarchy in "++f++" is up-to-date.") + genFile typeGenProgram (typeOpts tag) f + + case lookup "x-signals-file" xList of + Nothing -> return () + Just f -> do + info verb ("Ensuring that callback hooks in "++f++" are up-to-date.") + genFile signalGenProgram signalsOpts f + +--FIXME: Cabal should tell us the selected pkg-config package versions in the +-- LocalBuildInfo or equivalent. +-- In the mean time, ask pkg-config again. + +getPkgConfigPackages :: Verbosity -> LocalBuildInfo -> PackageDescription -> IO [PackageId] +getPkgConfigPackages verbosity lbi pkg = + sequence + [ do version <- pkgconfig ["--modversion", display pkgname] + case simpleParse version of + Nothing -> die $ "parsing output of pkg-config --modversion failed" + Just v -> return (PackageIdentifier pkgname v) + | Dependency pkgname _ <- concatMap pkgconfigDepends (allBuildInfo pkg) ] + where + pkgconfig = rawSystemProgramStdoutConf verbosity + pkgConfigProgram (withPrograms lbi) + +------------------------------------------------------------------------------ +-- Dependency calculation amongst .chs files. +------------------------------------------------------------------------------ + +-- Given all files of the package, find those that end in .chs and extract the +-- .chs files they depend upon. Then return the PackageDescription with these +-- files rearranged so that they are built in a sequence that files that are +-- needed by other files are built first. +fixDeps :: PackageDescription -> IO PackageDescription +fixDeps pd@PD.PackageDescription { + PD.library = Just lib@PD.Library { + PD.exposedModules = expMods, + PD.libBuildInfo = bi@PD.BuildInfo { + PD.hsSourceDirs = srcDirs, + PD.otherModules = othMods + }}} = do + let findModule m = findFileWithExtension [".chs.pp",".chs"] srcDirs + (joinPath (components m)) + mExpFiles <- mapM findModule expMods + mOthFiles <- mapM findModule othMods + + -- tag all exposed files with True so we throw an error if we need to build + -- an exposed module before an internal modules (we cannot express this) + let modDeps = zipWith (ModDep True []) expMods mExpFiles++ + zipWith (ModDep False []) othMods mOthFiles + modDeps <- mapM extractDeps modDeps + let (expMods, othMods) = span mdExposed $ sortTopological modDeps + badOther = map (fromMaybe "" . mdLocation) $ + filter (not . mdExposed) expMods + unless (null badOther) $ + die ("internal chs modules "++intercalate "," badOther++ + " depend on exposed chs modules; cabal needs to build internal modules first") + return pd { PD.library = Just lib { + PD.exposedModules = map mdOriginal expMods, + PD.libBuildInfo = bi { PD.otherModules = map mdOriginal othMods } + }} + +data ModDep = ModDep { + mdExposed :: Bool, + mdRequires :: [ModuleName], + mdOriginal :: ModuleName, + mdLocation :: Maybe FilePath +} + +instance Show ModDep where + show x = show (mdLocation x) + +instance Eq ModDep where + ModDep { mdOriginal = m1 } == ModDep { mdOriginal = m2 } = m1==m2 +instance Ord ModDep where + compare ModDep { mdOriginal = m1 } ModDep { mdOriginal = m2 } = compare m1 m2 + +-- Extract the dependencies of this file. This is intentionally rather naive as it +-- ignores CPP conditionals. We just require everything which means that the +-- existance of a .chs module may not depend on some CPP condition. +extractDeps :: ModDep -> IO ModDep +extractDeps md@ModDep { mdLocation = Nothing } = return md +extractDeps md@ModDep { mdLocation = Just f } = withFileContents f $ \con -> do + let findImports acc (('{':'#':xs):xxs) = case (dropWhile ((==) ' ') xs) of + ('i':'m':'p':'o':'r':'t':' ':ys) -> + case simpleParse (takeWhile ((/=) '#') ys) of + Just m -> findImports (m:acc) xxs + Nothing -> die ("cannot parse chs import in "++f++":\n"++ + "offending line is {#"++xs) + -- no more imports after the first non-import hook + _ -> return acc + findImports acc (_:xxs) = findImports acc xxs + findImports acc [] = return acc + mods <- findImports [] (lines con) + return md { mdRequires = mods } + +-- Find a total order of the set of modules that are partially sorted by their +-- dependencies on each other. The function returns the sorted list of modules +-- together with a list of modules that are required but not supplied by this +-- in the input set of modules. +sortTopological :: [ModDep] -> [ModDep] +sortTopological ms = reverse $ fst $ foldl visit ([], S.empty) (map mdOriginal ms) + where + set = M.fromList (map (\m -> (mdOriginal m, m)) ms) + visit (out,visited) m + | m `S.member` visited = (out,visited) + | otherwise = case m `M.lookup` set of + Nothing -> (out, m `S.insert` visited) + Just md -> (md:out', visited') + where + (out',visited') = foldl visit (out, m `S.insert` visited) (mdRequires md) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,7 @@ +-- Setup file for a Gtk2Hs module. Contains only adjustments specific to this module, +-- all Gtk2Hs-specific boilerplate is stored in Gtk2HsSetup.hs which should be kept +-- identical across all modules. +import Gtk2HsSetup ( gtk2hsUserHooks ) +import Distribution.Simple ( defaultMainWithHooks ) + +main = defaultMainWithHooks gtk2hsUserHooks diff --git a/System/Gnome/VFS.chs b/System/Gnome/VFS.chs new file mode 100644 --- /dev/null +++ b/System/Gnome/VFS.chs @@ -0,0 +1,69 @@ +{-# LANGUAGE CPP #-} +-- 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 Lesser General Public License +-- as published by the Free Software Foundation, either version 3 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this program. If not, see +-- . +-- +-- GnomeVFS, the C library which this Haskell library depends on, is +-- available under LGPL Version 2. The documentation included with +-- this library is based on the original GnomeVFS documentation, +-- Copyright (c) 2001 Seth Nickell . The +-- documentation is covered by the GNU Free Documentation License, +-- version 1.2. +-- +-- | Maintainer : gtk2hs-devel@lists.sourceforge.net +-- 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, +#if GNOME_VFS_CHECK_VERSION(2,14,0) + module System.Gnome.VFS.MIME, +#endif + 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 +#if GNOME_VFS_CHECK_VERSION(2,14,0) +import System.Gnome.VFS.MIME +#endif +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 diff --git a/System/Gnome/VFS/BasicTypes.chs b/System/Gnome/VFS/BasicTypes.chs new file mode 100644 --- /dev/null +++ b/System/Gnome/VFS/BasicTypes.chs @@ -0,0 +1,507 @@ +{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# OPTIONS_HADDOCK hide #-} +-- 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 Lesser General Public License +-- as published by the Free Software Foundation, either version 3 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this program. If not, see +-- . +-- +-- GnomeVFS, the C library which this Haskell library depends on, is +-- available under LGPL Version 2. The documentation included with +-- this library is based on the original GnomeVFS documentation, +-- Copyright (c) 2001 Seth Nickell . The +-- documentation is covered by the GNU Free Documentation License, +-- version 1.2. + +-- #hide + +-- | Maintainer : gtk2hs-devel@lists.sourceforge.net +-- Stability : alpha +-- Portability : portable (depends on GHC) +module System.Gnome.VFS.BasicTypes ( + + module System.Gnome.VFS.Constants, + + Handle(..), + withHandle, + + Result(..), + Error(..), + + OpenMode(..), + SeekPosition(..), + + FileInfo(..), + FileFlags(..), + FileInfoFields(..), + SetFileInfoMask(..), + FileInfoOptions(..), + FileSize, + FileOffset, + FileType(..), + InodeNumber, + IDs, + + MonitorHandle(..), + withMonitorHandle, + MonitorCallback, + MonitorType, + MonitorEventType, + + URI(..), + TextURI, + newURI, + withURI, + ToplevelURI(..), + newToplevelURI, + withToplevelURI, + URIHideOptions(..), + + DirectoryHandle(..), + withDirectoryHandle, + + MakeURIDirs(..), + DirectoryVisitOptions(..), + DirectoryVisitCallback, + DirectoryVisitResult(..), + FindDirectoryKind(..), + + XferOptions(..), + XferProgressStatus(..), + XferOverwriteMode(..), + XferOverwriteAction(..), + XferErrorMode(..), + XferErrorAction(..), + XferPhase(..), + XferProgressInfo(..), + XferProgressCallback, + XferErrorCallback, + XferOverwriteCallback, + XferDuplicateCallback, + + Cancellation(..), + newCancellation, + withCancellation, + + VolumeOpSuccessCallback, + VolumeOpFailureCallback, + CVolumeOpCallback, + VolumeType(..), + DeviceType(..), + +#if GNOME_VFS_CHECK_VERSION(2,14,0) + MIMEType, +#endif + + -- module System.Gnome.VFS.Hierarchy, + + DriveID, + newDrive, + withDrive, + + VolumeID, + newVolume, + withVolume, + + wrapVolumeMonitor, + withVolumeMonitor + + ) where + +import Control.Exception (assert) +import Control.Monad +import Control.Monad.Reader +import Data.Typeable +import Data.Word (Word64) +import System.Glib.FFI +import System.Glib.Flags +{#import System.Glib.GObject#} (GObject(..), + GObjectClass, + toGObject, + unsafeCastGObject) +{#import System.Glib.GType#} (GType, + typeInstanceIsA) +-- {#import System.Gnome.VFS.Hierarchy#} +{#import System.Gnome.VFS.Types#} +import System.Gnome.VFS.Constants + +import System.Posix.Types (DeviceID, EpochTime) + +-------------------------------------------------------------------- + +gTypeCast :: (GObjectClass obj, GObjectClass obj') => GType -> String + -> (obj -> obj') +-- The usage of foreignPtrToPtr should be safe as the evaluation will only be +-- forced if the object is used afterwards +gTypeCast gtype objTypeName obj = + case toGObject obj of + gobj@(GObject objFPtr) + | typeInstanceIsA ((unsafeForeignPtrToPtr.castForeignPtr) objFPtr) gtype + -> unsafeCastGObject gobj + | otherwise -> error $ "Cannot cast object to " ++ objTypeName + +-------------------------------------------------------------------- + +-- | The result of a file operation. +{# enum GnomeVFSResult as Result {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show, Typeable) #} + +newtype Error = Error Result + deriving (Show, Typeable) + +-- | A handle to an open file +{# pointer *GnomeVFSHandle as Handle foreign newtype #} +withHandle (Handle cHandle) = withForeignPtr cHandle + +-- | Specifies the start position for a seek operation. +{# enum GnomeVFSSeekPosition as SeekPosition {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #} +{# enum GnomeVFSOpenMode as OpenMode {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #} + +-------------------------------------------------------------------- + +-- | A record type containing information about a file. +data FileInfo = FileInfo { + fileInfoName :: Maybe String, -- ^ the name of the file, + -- without the path + fileInfoType :: Maybe FileType, -- ^ the type of the file; + -- i.e. regular, directory, + -- block-device, etc. + fileInfoPermissions :: Maybe [FilePermissions], -- ^ the permissions for the + -- file + fileInfoFlags :: Maybe [FileFlags], -- ^ flags providing + -- additional information + -- about the file + fileInfoDevice :: Maybe DeviceID, -- ^ the device the file + -- resides on + fileInfoInode :: Maybe InodeNumber, -- ^ the inode number of the + -- file + fileInfoLinkCount :: Maybe Int, -- ^ the total number of + -- hard links to the file + fileInfoIDs :: Maybe IDs, -- ^ the user and group IDs + -- owning the file + fileInfoSize :: Maybe FileSize, -- ^ the size of the file in + -- bytes + fileInfoBlockCount :: Maybe FileSize, -- ^ the size of the file in + -- filesystem blocks + fileInfoIOBlockSize :: Maybe FileSize, -- ^ the optimal buffer size + -- for reading from and + -- writing to the file + fileInfoATime :: Maybe EpochTime, -- ^ the time of last access + fileInfoMTime :: Maybe EpochTime, -- ^ the time of last modification + fileInfoCTime :: Maybe EpochTime, -- ^ the time of last attribute modification + fileInfoSymlinkName :: Maybe String -- ^ the location this + -- symlink points to, if + -- @fileInfoFlags@ contains 'FileFlagsSymlink' +#if GNOME_VFS_CHECK_VERSION(2,14,0) + , + fileInfoMIMEType :: Maybe MIMEType -- ^ the MIME-type of the + -- file +#endif + } deriving (Eq, Show) + +{# enum GnomeVFSFileInfoFields as FileInfoFields {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #} + +-- | Options for reading information from a file. +{# enum GnomeVFSFileInfoOptions as FileInfoOptions {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #} + +-- | Flags specifying additional information about a file. +{# enum GnomeVFSFileFlags as FileFlags {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #} + +-- | Flags specifying the attributes of a file that should be changed. +{# enum GnomeVFSSetFileInfoMask as SetFileInfoMask {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #} + +-- | Identifies the type of a file. +{# enum GnomeVFSFileType as FileType {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #} + +instance Flags FileInfoOptions +instance Flags FileInfoFields +instance Flags FileFlags +instance Flags SetFileInfoMask + +-- | An integral type wide enough to hold the size of a file. +type FileSize = Word64 + +-- | An integral type wide enough to hold an offset into a file. +type FileOffset = Word64 + +-- | An integral type wide enough to hold the inode number of a file. +type InodeNumber = Word64 + +-- | A pair holding the user ID and group ID of a file owner. +type IDs = (Int, Int) + +-------------------------------------------------------------------- + +-- | A 'URI' is a semi-textual representation of a uniform +-- resource identifier. It contains the information about a resource +-- location encoded as canononicalized text, but also holds extra +-- information about the context in which the URI is used. +{# pointer *GnomeVFSURI as URI foreign newtype #} + +newURI :: Ptr URI + -> IO URI +newURI cURI | cURI /= nullPtr = + liftM URI $ newForeignPtr cURI cURIFinalizer +wrapURI :: Ptr URI + -> IO URI +wrapURI cURI | cURI /= nullPtr = + liftM URI $ newForeignPtr_ cURI +foreign import ccall "&gnome_vfs_uri_unref" + cURIFinalizer :: FunPtr (Ptr URI -> IO ()) + +withURI (URI cURI) = withForeignPtr cURI + +-- | The toplevel URI element used to access resources stored on a +-- remote server. +{# pointer *GnomeVFSToplevelURI as ToplevelURI foreign newtype #} +withToplevelURI (ToplevelURI cToplevelURI) = withForeignPtr cToplevelURI +newToplevelURI :: Ptr ToplevelURI + -> IO ToplevelURI +newToplevelURI cToplevelURI = liftM ToplevelURI $ newForeignPtr_ cToplevelURI + +-- | Flags specifying which fields of a 'URI' should be hidden when +-- converted to a string using 'uriToString'. +{# enum GnomeVFSURIHideOptions as URIHideOptions { + GNOME_VFS_URI_HIDE_NONE as URIHideNone, + GNOME_VFS_URI_HIDE_USER_NAME as URIHideUserName, + GNOME_VFS_URI_HIDE_PASSWORD as URIHidePassword, + GNOME_VFS_URI_HIDE_HOST_NAME as URIHideHostName, + GNOME_VFS_URI_HIDE_HOST_PORT as URIHideHostPort, + GNOME_VFS_URI_HIDE_TOPLEVEL_METHOD as URIHideToplevelMethod, + GNOME_VFS_URI_HIDE_FRAGMENT_IDENTIFIER as URIHideFragmentIdentifier + } deriving (Eq, Bounded, Show) #} +instance Flags URIHideOptions + +-- | A string that can be passed to 'uriFromString' to create a valid +-- 'URI'. +type TextURI = String + +-------------------------------------------------------------------- + +-- | A handle to an open directory. +{# pointer *GnomeVFSDirectoryHandle as DirectoryHandle foreign newtype #} +withDirectoryHandle (DirectoryHandle cDirectoryHandle) = withForeignPtr cDirectoryHandle + +-- | Options controlling the way in which a directories are visited. +{# enum GnomeVFSDirectoryVisitOptions as DirectoryVisitOptions {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #} +instance Flags DirectoryVisitOptions + +-- | A callback that will be called for each entry when passed to +-- 'directoryVisit', 'directoryVisitURI', 'directoryVisitFiles', or +-- 'directoryVisitFilesAtURI'. +-- +-- The parameters, from left to right, are: +-- * the path of the visited file, relative to the base directory, +-- * the 'FileInfo' for the visited file, +-- * 'True' if returning 'DirectoryVisitRecurse' will cause a loop, otherwise 'False'. +-- +-- The callback must return the next action to be taken. +type DirectoryVisitCallback = String + -> FileInfo + -> Bool + -> IO DirectoryVisitResult + +-- | An enumerated value that must be returned from a +-- 'DirectoryVisitCallback'. The 'directoryVisit' and related +-- functions will perform the action specified. +data DirectoryVisitResult = DirectoryVisitStop -- ^ stop visiting files + | DirectoryVisitContinue -- ^ continue as normal + | DirectoryVisitRecurse -- ^ recursively visit the current entry + deriving (Eq, Enum) + +-- | Specifies which kind of directory 'findDirectory' should look for. +{# enum GnomeVFSFindDirectoryKind as FindDirectoryKind {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #} + +-------------------------------------------------------------------- + +-- | Flags that may be passed to 'makeURIFromInputWithDirs'. If the +-- path passed is non-absolute (i.e., a relative path), the +-- directories specified will be searched as well. +{# enum GnomeVFSMakeURIDirs as MakeURIDirs {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #} +instance Flags MakeURIDirs + +-------------------------------------------------------------------- + +-- | A handle to a file-system monitor. +newtype MonitorHandle = MonitorHandle (ForeignPtr MonitorHandle, {# type GnomeVFSMonitorCallback #}) +withMonitorHandle (MonitorHandle (monitorHandleForeignPtr, _)) = withForeignPtr monitorHandleForeignPtr + +-- | A callback that must be passed to 'monitorAdd'. It will be +-- called any time a file or directory is changed. +-- +-- The parameters, from left to right, are: +-- * the handle to a filesystem monitor, +-- * the URI being monitored, +-- * the actual file that was modified, +-- * the event that occured. +type MonitorCallback = MonitorHandle + -> TextURI + -> TextURI + -> MonitorEventType + -> IO () + +-- | The type of filesystem object that is to be monitored. +{# enum GnomeVFSMonitorType as MonitorType {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #} + +-- | The type of event that caused a 'MonitorCallback' to be called. +{# enum GnomeVFSMonitorEventType as MonitorEventType {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #} +wrapMonitorHandle :: (Ptr MonitorHandle, {# type GnomeVFSMonitorCallback #}) + -> IO MonitorHandle +wrapMonitorHandle (cMonitorHandle, cMonitorCallback) = + do monitorHandleForeignPtr <- newForeignPtr_ cMonitorHandle + return $ MonitorHandle (monitorHandleForeignPtr, cMonitorCallback) + +-------------------------------------------------------------------- + +-- | Options controlling how the 'System.Gnome.VFS.Xfer.xferURI' and related functions behave. +{# enum GnomeVFSXferOptions as XferOptions {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #} +instance Flags XferOptions + +{# enum GnomeVFSXferProgressStatus as XferProgressStatus {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #} +{# enum GnomeVFSXferOverwriteMode as XferOverwriteMode {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #} +{# enum GnomeVFSXferOverwriteAction as XferOverwriteAction {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #} +{# enum GnomeVFSXferErrorMode as XferErrorMode {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #} +{# enum GnomeVFSXferErrorAction as XferErrorAction {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #} +{# enum GnomeVFSXferPhase as XferPhase {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #} + +data XferProgressInfo = XferProgressInfo { + xferProgressInfoVFSStatus :: Result, -- ^ current VFS status + xferProgressInfoPhase :: XferPhase, -- ^ phase of the transfer + xferProgressInfoSourceName :: Maybe String, -- ^ currently transferring source URI + xferProgressInfoTargetName :: Maybe String, -- ^ currently transferring target URI + xferProgressInfoFileIndex :: Word, -- ^ index of the file currently being transferred + xferProgressInfoFilesTotal :: Word, -- ^ total number of files being transferred + xferProgressInfoBytesTotal :: FileSize, -- ^ total size of all files in bytes + xferProgressInfoFileSize :: FileSize, -- ^ size of the file currently being transferred + xferProgressInfoBytesCopied :: FileSize, -- ^ number of bytes already transferred in the current file + xferProgressInfoTotalBytesCopied :: FileSize, -- ^ total number of bytes already transferred + xferProgressInfoTopLevelItem :: Bool -- ^ 'True' if the file being transferred is a top-level item; + -- 'False' if it is inside a directory + } deriving (Eq) + +-- | The type of the first callback that is passed to +-- 'System.Gnome.VFS.Xfer.xferURI' and related functions. This +-- callback will be called periodically during transfers that are +-- progressing normally. +-- +-- The callback must return 'Prelude.False' to abort the transfer, or 'Prelude.True' otherwise. +type XferProgressCallback = XferProgressInfo + -> IO Bool + +-- | The type of the second callback that is passed to +-- 'System.Gnome.VFS.Xfer.xferURI'. This callback will be called +-- whenever an error occurs. +-- +-- The callback must return the action to be performed in response to the error. +type XferErrorCallback = XferProgressInfo + -> IO XferErrorAction + +-- | The type of the third callback that is passed to +-- 'System.Gnome.VFS.Xfer.xferURI'. This callback will be called +-- when a file would be overwritten. +-- +-- The callback must return the action to be performed when the target file already exists. +type XferOverwriteCallback = XferProgressInfo + -> IO XferOverwriteAction + +-- | The type of the fourth callback that is passed to +-- 'System.Gnome.VFS.Xfer.xferURI'. This callback will be called +-- when a duplicate filename is found. +-- +-- The parameters, from left to right, are: +-- * @info@ - information about the progress of the current transfer, +-- * @duplicateName@ - the name of the target file, +-- * @duplicateCount@ - the number of duplicates that exist. +-- +-- The callback must return the new filename that should be used, or 'Prelude.Nothing' to abort. +type XferDuplicateCallback = XferProgressInfo + -> String + -> Int + -> IO (Maybe String) + +-------------------------------------------------------------------- + +-- | An object that can be used for signalling cancellation of an +-- operation. +{# pointer *GnomeVFSCancellation as Cancellation foreign newtype #} + +newCancellation :: Ptr Cancellation + -> IO Cancellation +newCancellation cCancellationPtr | cCancellationPtr /= nullPtr = + liftM Cancellation $ newForeignPtr cCancellationPtr cancellationFinalizer +foreign import ccall unsafe "&gnome_vfs_cancellation_destroy" + cancellationFinalizer :: FunPtr (Ptr Cancellation -> IO ()) +withCancellation (Cancellation cCancellation) = withForeignPtr cCancellation + +-------------------------------------------------------------------- + +withVolume (Volume cVolume) = withForeignPtr cVolume +newVolume :: Ptr Volume + -> IO Volume +newVolume cVolume | cVolume /= nullPtr = + liftM Volume $ newForeignPtr cVolume volumeFinalizer +foreign import ccall unsafe "&gnome_vfs_volume_unref" + volumeFinalizer :: FunPtr (Ptr Volume -> IO ()) + +-- | An action to be performed when a volume operation completes successfully. +type VolumeOpSuccessCallback = IO () +-- | An action to be performed when a volume operation fails. +type VolumeOpFailureCallback = String + -> String + -> IO () + +-- | Identifies the device type of a 'Volume' or 'Drive'. +{#enum GnomeVFSDeviceType as DeviceType {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #} +-- | Identifies the type of a 'Volume'. +{#enum GnomeVFSVolumeType as VolumeType {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #} + +type CVolumeOpCallback = {# type gboolean #} + -> CString + -> CString + -> Ptr () + -> IO () + +-------------------------------------------------------------------- + +-- | Identifies a 'Drive' +type DriveID = {# type gulong #} + +withDrive (Drive cDrive) = withForeignPtr cDrive +newDrive :: Ptr Drive + -> IO Drive +newDrive cDrive | cDrive /= nullPtr = + liftM Drive $ newForeignPtr cDrive driveFinalizer +foreign import ccall unsafe "&gnome_vfs_drive_unref" + driveFinalizer :: FunPtr (Ptr Drive -> IO ()) + +-------------------------------------------------------------------- + +-- | Identifies a 'Volume'. +type VolumeID = {# type gulong #} + +withVolumeMonitor (VolumeMonitor cVolumeMonitor) = withForeignPtr cVolumeMonitor +wrapVolumeMonitor :: Ptr VolumeMonitor + -> IO VolumeMonitor +wrapVolumeMonitor cVolumeMonitor | cVolumeMonitor /= nullPtr = + liftM VolumeMonitor $ newForeignPtr_ cVolumeMonitor + +-------------------------------------------------------------------- + +#if GNOME_VFS_CHECK_VERSION(2,14,0) +-- | A string that will be treated as a MIME-type. +type MIMEType = String +#endif diff --git a/System/Gnome/VFS/Cancellation.chs b/System/Gnome/VFS/Cancellation.chs new file mode 100644 --- /dev/null +++ b/System/Gnome/VFS/Cancellation.chs @@ -0,0 +1,97 @@ +{-# LANGUAGE CPP #-} +-- 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 Lesser General Public License +-- as published by the Free Software Foundation, either version 3 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this program. If not, see +-- . +-- +-- GnomeVFS, the C library which this Haskell library depends on, is +-- available under LGPL Version 2. The documentation included with +-- this library is based on the original GnomeVFS documentation, +-- Copyright (c) 2001 Seth Nickell . The +-- documentation is covered by the GNU Free Documentation License, +-- version 1.2. +-- +-- | Maintainer : gtk2hs-devel@lists.sourceforge.net +-- 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.Gnome.VFS.BasicTypes#} +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 diff --git a/System/Gnome/VFS/Constants.hsc b/System/Gnome/VFS/Constants.hsc new file mode 100644 --- /dev/null +++ b/System/Gnome/VFS/Constants.hsc @@ -0,0 +1,112 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_HADDOCK hide #-} +-- GIMP Toolkit (GTK) Binding for Haskell: binding to libgnomevfs -*-haskell-*- +-- +-- Author : Peter Gavin +-- Created: 21-Jun-2008 +-- +-- Copyright (c) 2008 Peter Gavin +-- +-- This library is free software: you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public License +-- as published by the Free Software Foundation, either version 3 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this program. If not, see +-- . +-- +-- GnomeVFS, the C library which this Haskell library depends on, is +-- available under LGPL Version 2. The documentation included with +-- this library is based on the original GnomeVFS documentation, +-- Copyright (c) 2001 Seth Nickell . The +-- documentation is covered by the GNU Free Documentation License, +-- version 1.2. + +-- #hide + +#include + +-- | Maintainer : gtk2hs-devel@lists.sourceforge.net +-- Stability : alpha +-- Portability : portable (depends on GHC) +module System.Gnome.VFS.Constants ( + + FilePermissions (..), + permUserAll, + permGroupAll, + permOtherAll + + ) where + +import System.Glib.Flags + +-- | UNIX-like permissions for a file. +data FilePermissions +#ifndef WIN32 + = PermSUID + | PermSGID + | PermSticky +#else + = PermSticky +#endif + | PermUserRead + | PermUserWrite + | PermUserExec + | PermGroupRead + | PermGroupWrite + | PermGroupExec + | PermOtherRead + | PermOtherWrite + | PermOtherExec + | PermAccessReadable + | PermAccessWritable + | PermAccessExecutable + deriving (Eq, Ord, Bounded, Show, Read) +instance Flags FilePermissions +permUserAll, permGroupAll, permOtherAll :: [FilePermissions] +permUserAll = [ PermUserRead, PermUserWrite, PermUserExec ] +permGroupAll = [ PermGroupRead, PermGroupWrite, PermGroupExec ] +permOtherAll = [ PermOtherRead, PermOtherWrite, PermOtherExec ] + +instance Enum FilePermissions where +#ifndef WIN32 + fromEnum PermSUID = #{const GNOME_VFS_PERM_SUID} + fromEnum PermSGID = #{const GNOME_VFS_PERM_SGID} +#endif + fromEnum PermSticky = #{const GNOME_VFS_PERM_STICKY} + fromEnum PermUserRead = #{const GNOME_VFS_PERM_USER_READ} + fromEnum PermUserWrite = #{const GNOME_VFS_PERM_USER_WRITE} + fromEnum PermUserExec = #{const GNOME_VFS_PERM_USER_EXEC} + fromEnum PermGroupRead = #{const GNOME_VFS_PERM_GROUP_READ} + fromEnum PermGroupWrite = #{const GNOME_VFS_PERM_GROUP_WRITE} + fromEnum PermGroupExec = #{const GNOME_VFS_PERM_GROUP_EXEC} + fromEnum PermOtherRead = #{const GNOME_VFS_PERM_OTHER_READ} + fromEnum PermOtherWrite = #{const GNOME_VFS_PERM_OTHER_WRITE} + fromEnum PermOtherExec = #{const GNOME_VFS_PERM_OTHER_EXEC} + fromEnum PermAccessReadable = #{const GNOME_VFS_PERM_ACCESS_READABLE} + fromEnum PermAccessWritable = #{const GNOME_VFS_PERM_ACCESS_WRITABLE} + fromEnum PermAccessExecutable = #{const GNOME_VFS_PERM_ACCESS_EXECUTABLE} + +#ifndef WIN32 + toEnum #{const GNOME_VFS_PERM_SUID} = PermSUID + toEnum #{const GNOME_VFS_PERM_SGID} = PermSGID +#endif + toEnum #{const GNOME_VFS_PERM_STICKY} = PermSticky + toEnum #{const GNOME_VFS_PERM_USER_READ} = PermUserRead + toEnum #{const GNOME_VFS_PERM_USER_WRITE} = PermUserWrite + toEnum #{const GNOME_VFS_PERM_USER_EXEC} = PermUserExec + toEnum #{const GNOME_VFS_PERM_GROUP_READ} = PermGroupRead + toEnum #{const GNOME_VFS_PERM_GROUP_WRITE} = PermGroupWrite + toEnum #{const GNOME_VFS_PERM_GROUP_EXEC} = PermGroupExec + toEnum #{const GNOME_VFS_PERM_OTHER_READ} = PermOtherRead + toEnum #{const GNOME_VFS_PERM_OTHER_WRITE} = PermOtherWrite + toEnum #{const GNOME_VFS_PERM_OTHER_EXEC} = PermOtherExec + toEnum #{const GNOME_VFS_PERM_ACCESS_READABLE} = PermAccessReadable + toEnum #{const GNOME_VFS_PERM_ACCESS_WRITABLE} = PermAccessWritable + toEnum #{const GNOME_VFS_PERM_ACCESS_EXECUTABLE} = PermAccessExecutable diff --git a/System/Gnome/VFS/Directory.chs b/System/Gnome/VFS/Directory.chs new file mode 100644 --- /dev/null +++ b/System/Gnome/VFS/Directory.chs @@ -0,0 +1,254 @@ +{-# LANGUAGE CPP, ScopedTypeVariables #-} +-- 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 Lesser General Public License +-- as published by the Free Software Foundation, either version 3 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this program. If not, see +-- . +-- +-- GnomeVFS, the C library which this Haskell library depends on, is +-- available under LGPL Version 2. The documentation included with +-- this library is based on the original GnomeVFS documentation, +-- Copyright (c) 2001 Seth Nickell . The +-- documentation is covered by the GNU Free Documentation License, +-- version 1.2. +-- +-- | Maintainer : gtk2hs-devel@lists.sourceforge.net +-- 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.BasicTypes#} +{#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 ()) diff --git a/System/Gnome/VFS/Drive.chs b/System/Gnome/VFS/Drive.chs new file mode 100644 --- /dev/null +++ b/System/Gnome/VFS/Drive.chs @@ -0,0 +1,293 @@ +{-# LANGUAGE CPP #-} +-- 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 Lesser General Public License +-- as published by the Free Software Foundation, either version 3 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this program. If not, see +-- . +-- +-- GnomeVFS, the C library which this Haskell library depends on, is +-- available under LGPL Version 2. The documentation included with +-- this library is based on the original GnomeVFS documentation, +-- Copyright (c) 2001 Seth Nickell . The +-- documentation is covered by the GNU Free Documentation License, +-- version 1.2. +-- +-- | Maintainer : gtk2hs-devel@lists.sourceforge.net +-- Stability : alpha +-- Portability : portable (depends on GHC) +module System.Gnome.VFS.Drive ( + +-- * Types + -- | A container for 'Volume's. + Drive, + DriveClass, + DriveID, + DeviceType, + +-- * Type Conversion + castToDrive, + +-- * Drive Comparison + driveCompare, + +-- * Drive Properties + driveGetActivationURI, + driveGetDevicePath, + driveGetDeviceType, + driveGetDisplayName, +#if GNOME_VFS_CHECK_VERSION(2,8,0) + driveGetHalUDI, +#endif + driveGetIcon, + driveGetID, + +-- * Drive State + driveIsConnected, + driveIsMounted, + driveIsUserVisible, +#if GNOME_VFS_CHECK_VERSION(2,8,0) + driveGetMountedVolumes, +#endif + +-- * 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#} +{#import System.Gnome.VFS.BasicTypes#} + +{# 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 'System.Gnome.VFS.Volume.volumeUnmount' for +-- each volume in 'driveGetMountedVolumes', except for the last one, +-- for which 'System.Gnome.VFS.Volume.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 +-- 'System.Gnome.VFS.URI.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 #} + +#if GNOME_VFS_CHECK_VERSION(2,8,0) +-- | 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 #} +#endif + +-- | 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 DriveID -- ^ a unique identifier for the drive +driveGetID drive = + {# call drive_get_id #} (castToDrive drive) + + +#if GNOME_VFS_CHECK_VERSION(2,8,0) +-- | 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 +#endif + +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) => + drive -- ^ @drive@ - the drive to connect the signal handler to + -> (Volume -> IO ()) -- ^ @handler@ - the signal handling function + -> IO (ConnectId drive) -- ^ the identifier for the connection + +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 diff --git a/System/Gnome/VFS/Error.chs b/System/Gnome/VFS/Error.chs new file mode 100644 --- /dev/null +++ b/System/Gnome/VFS/Error.chs @@ -0,0 +1,69 @@ +{-# LANGUAGE CPP #-} +-- 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 Lesser General Public License +-- as published by the Free Software Foundation, either version 3 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this program. If not, see +-- . +-- +-- GnomeVFS, the C library which this Haskell library depends on, is +-- available under LGPL Version 2. The documentation included with +-- this library is based on the original GnomeVFS documentation, +-- Copyright (c) 2001 Seth Nickell . The +-- documentation is covered by the GNU Free Documentation License, +-- version 1.2. +-- +-- | Maintainer : gtk2hs-devel@lists.sourceforge.net +-- Stability : alpha +-- Portability : portable (depends on GHC) +module System.Gnome.VFS.Error ( + + Error(..), + + error, + errors, + eofErrors, + + ) where + +import Control.Monad (join) +#ifdef HAVE_NEW_CONTROL_EXCEPTION +import qualified Control.OldException as E +#else +import qualified Control.Exception as E +#endif +import Data.Dynamic +-- import System.Gnome.VFS.Types +import System.Gnome.VFS.BasicTypes +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 diff --git a/System/Gnome/VFS/FileInfo.chs b/System/Gnome/VFS/FileInfo.chs new file mode 100644 --- /dev/null +++ b/System/Gnome/VFS/FileInfo.chs @@ -0,0 +1,333 @@ +{-# LANGUAGE CPP #-} + +-- 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 Lesser General Public License +-- as published by the Free Software Foundation, either version 3 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this program. If not, see +-- . +-- +-- GnomeVFS, the C library which this Haskell library depends on, is +-- available under LGPL Version 2. The documentation included with +-- this library is based on the original GnomeVFS documentation, +-- Copyright (c) 2001 Seth Nickell . The +-- documentation is covered by the GNU Free Documentation License, +-- version 1.2. +-- +-- | Maintainer : gtk2hs-devel@lists.sourceforge.net +-- 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.Gnome.VFS.BasicTypes#} +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 +#if GNOME_VFS_CHECK_VERSION(2,14,0) + ids <- maybeField FileInfoFieldsIds $ + do uid <- liftM fromIntegral $ {# get GnomeVFSFileInfo->uid #} ptr + gid <- liftM fromIntegral $ {# get GnomeVFSFileInfo->gid #} ptr + return $ (uid, gid) +#else + uid <- liftM fromIntegral $ {# get GnomeVFSFileInfo->uid #} ptr + gid <- liftM fromIntegral $ {# get GnomeVFSFileInfo->gid #} ptr + let ids = Just (uid, gid) +#endif + + 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 +#if GNOME_VFS_CHECK_VERSION(2,14,0) + mimeType <- maybeField FileInfoFieldsMimeType $ + {# call file_info_get_mime_type #} (castPtr ptr) >>= peekUTFString +#endif + return $ FileInfo name + fileType + permissions + fileFlags + device + inode + linkCount + ids + size + blockCount + ioBlockSize + aTime + mTime + cTime + symlinkName +#if GNOME_VFS_CHECK_VERSION(2,14,0) + mimeType +#endif + poke ptr (FileInfo name + fileType + permissions + fileFlags + device + inode + linkCount + ids + size + blockCount + ioBlockSize + aTime + mTime + cTime + symlinkName +#if GNOME_VFS_CHECK_VERSION(2,14,0) + mimeType +#endif + ) = + 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 + 0 + (return . cFromEnum) + cFileInfoSetType, + + marshaller FileInfoFieldsPermissions + permissions + 0 + (return . cFromFlags) + {# set GnomeVFSFileInfo->permissions #}, + + marshaller FileInfoFieldsFlags + fileFlags + 0 + (return . cFromFlags) + {# set GnomeVFSFileInfo->flags #}, + + marshaller FileInfoFieldsDevice + device + 0 + (return . cFromEnum) + {# set GnomeVFSFileInfo->device #}, + + marshaller FileInfoFieldsInode + inode + 0 + (return . fromIntegral) + {# set GnomeVFSFileInfo->inode #}, + + marshaller FileInfoFieldsLinkCount + linkCount + 0 + (return . fromIntegral) + {# set GnomeVFSFileInfo->link_count #}, + +#if GNOME_VFS_CHECK_VERSION(2,14,0) + marshaller FileInfoFieldsIds + ids + (0, 0) + (\(uid, gid) -> return (fromIntegral uid, fromIntegral gid)) + (\ptr (uid, gid) -> + do {# set GnomeVFSFileInfo->uid #} ptr uid + {# set GnomeVFSFileInfo->gid #} ptr gid), +#endif + + marshaller FileInfoFieldsSize + size + 0 + (return . fromIntegral) + cFileInfoSetSize, + + marshaller FileInfoFieldsBlockCount + blockCount + 0 + (return . fromIntegral) + {# set GnomeVFSFileInfo->block_count #}, + + marshaller FileInfoFieldsIoBlockSize + ioBlockSize + 0 + (return . fromIntegral) + {# set GnomeVFSFileInfo->io_block_size #}, + + marshaller FileInfoFieldsAtime + aTime + 0 + (return . cFromEnum) + {# set GnomeVFSFileInfo->atime #}, + + marshaller FileInfoFieldsMtime + mTime + 0 + (return . cFromEnum) + {# set GnomeVFSFileInfo->mtime #}, + + marshaller FileInfoFieldsCtime + cTime + 0 + (return . cFromEnum) + {# set GnomeVFSFileInfo->ctime #}, + + marshaller FileInfoFieldsSymlinkName + symlinkName + nullPtr + newUTFString + (\ptr str -> + do {# get GnomeVFSFileInfo->symlink_name #} ptr >>= (gFree . castPtr) + {# set GnomeVFSFileInfo->symlink_name #} ptr str), + + marshaller FileInfoFieldsMimeType + symlinkName + nullPtr + newUTFString + (\ptr str -> + do {# get GnomeVFSFileInfo->mime_type #} ptr >>= (gFree . castPtr) + {# set GnomeVFSFileInfo->mime_type #} ptr str) ] + +#if !GNOME_VFS_CHECK_VERSION(2,14,0) + case ids of + Just (uid, gid) -> + do {# set GnomeVFSFileInfo->uid #} ptr $ fromIntegral uid + {# set GnomeVFSFileInfo->gid #} ptr $ fromIntegral gid + Nothing -> + return () +#endif + + {# set GnomeVFSFileInfo->valid_fields #} ptr $ cFromFlags validFields + +gFree = {# call g_free #} + +foreign import ccall unsafe "_hs_gnome_vfs_file_info_get_type" + cFileInfoGetType :: Ptr FileInfo + -> IO {# type GnomeVFSFileType #} +foreign import ccall unsafe "_hs_gnome_vfs_file_info_get_inode" + cFileInfoGetInode :: Ptr FileInfo + -> IO CULLong +foreign import ccall unsafe "_hs_gnome_vfs_file_info_get_size" + cFileInfoGetSize :: Ptr FileInfo + -> IO CULLong +foreign import ccall unsafe "_hs_gnome_vfs_file_info_get_block_count" + cFileInfoGetBlockCount :: Ptr FileInfo + -> IO CULLong + +foreign import ccall unsafe "_hs_gnome_vfs_file_info_set_type" + cFileInfoSetType :: Ptr FileInfo + -> {# type GnomeVFSFileType #} + -> IO () +foreign import ccall unsafe "_hs_gnome_vfs_file_info_get_inode" + cFileInfoSetInode :: Ptr FileInfo + -> CULLong + -> IO () +foreign import ccall unsafe "_hs_gnome_vfs_file_info_set_size" + cFileInfoSetSize :: Ptr FileInfo + -> {# type GnomeVFSFileSize #} + -> IO () +foreign import ccall unsafe "_hs_gnome_vfs_file_info_set_block_count" + cFileInfoSetBlockCount :: Ptr FileInfo + -> CULLong + -> IO () diff --git a/System/Gnome/VFS/Init.chs b/System/Gnome/VFS/Init.chs new file mode 100644 --- /dev/null +++ b/System/Gnome/VFS/Init.chs @@ -0,0 +1,62 @@ +{-# LANGUAGE CPP #-} +-- 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 Lesser General Public License +-- as published by the Free Software Foundation, either version 3 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this program. If not, see +-- . +-- +-- GnomeVFS, the C library which this Haskell library depends on, is +-- available under LGPL Version 2. The documentation included with +-- this library is based on the original GnomeVFS documentation, +-- Copyright (c) 2001 Seth Nickell . The +-- documentation is covered by the GNU Free Documentation License, +-- version 1.2. +-- +-- | Maintainer : gtk2hs-devel@lists.sourceforge.net +-- Stability : alpha +-- Portability : portable (depends on GHC) +module System.Gnome.VFS.Init ( + +-- * Initialization and Shutdown + init, + shutdown, + initialized + + ) where + +import System.Glib.FFI +import Control.Monad (liftM) +import Prelude hiding (init) + +{# context lib = "gnomevfs" prefix = "gnome_vfs" #} + +-- | If gnome-vfs is not already initialized, initialize it. This must +-- be called prior to performing any other gnome-vfs operations, and +-- may be called multiple times without error. +init :: IO Bool +init = liftM toBool {# call gnome_vfs_init #} + +-- | Cease all active gnome-vfs operations and unload the MIME database +-- from memory. +shutdown :: IO () +shutdown = {# call gnome_vfs_shutdown #} + +-- | Detects if gnome-vfs has already been initialized (gnome-vfs must +-- be initialized prior to using any methods or operations). +initialized :: IO Bool +initialized = liftM toBool {# call gnome_vfs_initialized #} diff --git a/System/Gnome/VFS/MIME.chs b/System/Gnome/VFS/MIME.chs new file mode 100644 --- /dev/null +++ b/System/Gnome/VFS/MIME.chs @@ -0,0 +1,143 @@ +{-# LANGUAGE CPP #-} +-- 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 Lesser General Public License +-- as published by the Free Software Foundation, either version 3 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this program. If not, see +-- . +-- +-- GnomeVFS, the C library which this Haskell library depends on, is +-- available under LGPL Version 2. The documentation included with +-- this library is based on the original GnomeVFS documentation, +-- Copyright (c) 2001 Seth Nickell . The +-- documentation is covered by the GNU Free Documentation License, +-- version 1.2. +-- +-- | Maintainer : gtk2hs-devel@lists.sourceforge.net +-- Stability : alpha +-- Portability : portable (depends on GHC) +module System.Gnome.VFS.MIME ( + +-- * Types + MIMEType, + +-- * MIME Type Operations + mimeTypeFromNameOrDefault, + getMIMETypeCommon, + getMIMETypeFromURI, + getFileMIMETypeFast, + getFileMIMEType, + mimeTypeIsSupertype, + getSupertypeFromMIMEType, + mimeInfoCacheReload + + ) where + +import Control.Monad (liftM) +import System.Glib.Flags +import System.Glib.FFI +import System.Glib.UTFString +-- {#import System.Gnome.VFS.Types#} +{#import System.Gnome.VFS.BasicTypes#} +{#import System.Gnome.VFS.Marshal#} + +{# context lib = "gnomevfs" prefix = "gnome_vfs" #} + +-- | Try to determine the MIME-type of the file at @filename@, using +-- only the filename and the Gnome VFS MIME type database. If the +-- MIME-type is not found, return @defaultv@. +mimeTypeFromNameOrDefault :: FilePath -- ^ @filename@ - the file + -- to get the MIME-type + -- for + -> Maybe MIMEType -- ^ @defaultv@ - the + -- default MIME-type to + -- return if no match is + -- found + -> Maybe MIMEType -- ^ the MIME-type of the + -- filename, or @defaultv@ +mimeTypeFromNameOrDefault filename defaultv = + unsafePerformIO $ maybeWith withUTFString defaultv $ \cDefaultv -> + withUTFString filename $ \cFilename -> + {# call mime_type_from_name_or_default #} cFilename cDefaultv >>= + maybePeek peekUTFString + +-- | Try to get the MIME-type of the file represented by @uri@. This +-- function favors the contents of the file over the extension of +-- the filename. If the file does not exist, the MIME-type for the +-- extension is returned. If no MIME-type can be found for the file, +-- the function returns \"application\/octet-stream\". +-- +-- Note: This function will not necessarily return the same +-- MIME-type as 'System.Gnome.VFS.Ops.getFileInfo'. +getMIMETypeCommon :: URI -- ^ @uri@ - the URI of the file to examine + -> IO String -- ^ the guessed MIME-type +getMIMETypeCommon uri = + {# call get_mime_type_common #} uri >>= peekUTFString + +-- | Try to get the MIME-type of the file represented by @uri@. This +-- function looks only at the filename pointed to by @uri@. +getMIMETypeFromURI :: URI -- ^ @uri@ - the URI to examine + -> IO String -- ^ the guessed MIME-type +getMIMETypeFromURI uri = + {# call get_mime_type_from_uri #} uri >>= peekUTFString + +getFileMIMETypeFast :: FilePath -- ^ + -> IO String +getFileMIMETypeFast path = + withUTFString path $ \cPath -> + {# call get_file_mime_type_fast #} cPath nullPtr >>= + peekUTFString + +-- | Try to guess the MIME-type of the file represented by @path@. If +-- @suffixOnly@ is 'False', use the MIME-magic based lookup +-- first. Handles non-existant files by returning a type based on +-- the file extension. +getFileMIMEType :: FilePath + -> Bool + -> IO String +getFileMIMEType path suffixOnly = + withUTFString path $ \cPath -> + let cSuffixOnly = fromBool suffixOnly + in {# call get_file_mime_type #} cPath nullPtr cSuffixOnly >>= + peekUTFString + +-- | Returns 'True' if @mimeType@ is of the form @foo\/\*@, and 'False' +-- otherwise. +mimeTypeIsSupertype :: String + -> Bool +mimeTypeIsSupertype mimeType = + toBool $ unsafePerformIO $ + withUTFString mimeType {# call mime_type_is_supertype #} + +-- | Returns the supertype for @mimeType@. The supertype of an +-- application is computed by removing its suffix, and replacing it +-- with @\*@. Thus, @foo\/bar@ will be converted to @foo\/\*@. +getSupertypeFromMIMEType :: String + -> String +getSupertypeFromMIMEType mimeType = + unsafePerformIO $ withUTFString mimeType {# call get_supertype_from_mime_type #} >>= + readUTFString + +-- | Reload the MIME information for the specified directory. +mimeInfoCacheReload :: FilePath + -> IO () +mimeInfoCacheReload dir = + withUTFString dir {# call mime_info_cache_reload #} + +-- | Reload the MIME database. +mimeReload :: IO () +mimeReload = {# call mime_reload #} diff --git a/System/Gnome/VFS/Marshal.chs b/System/Gnome/VFS/Marshal.chs new file mode 100644 --- /dev/null +++ b/System/Gnome/VFS/Marshal.chs @@ -0,0 +1,129 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_HADDOCK hide #-} +-- 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 Lesser General Public License +-- as published by the Free Software Foundation, either version 3 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this program. If not, see +-- . +-- +-- GnomeVFS, the C library which this Haskell library depends on, is +-- available under LGPL Version 2. The documentation included with +-- this library is based on the original GnomeVFS documentation, +-- Copyright (c) 2001 Seth Nickell . The +-- documentation is covered by the GNU Free Documentation License, +-- version 1.2. + +-- #hide + +-- | Maintainer : gtk2hs-devel@lists.sourceforge.net +-- Stability : alpha +-- Portability : portable (depends on GHC) +module System.Gnome.VFS.Marshal ( + + cToEnum, + cFromEnum, + cToBool, + cFromBool, + cToFlags, + cFromFlags, + genericResultMarshal, + voidResultMarshal, + newObjectResultMarshal, + volumeOpCallbackMarshal + + ) where + +import Control.Exception +import Control.Monad (liftM) +import Data.Dynamic +import System.Glib.FFI +import System.Glib.Flags (Flags, toFlags, fromFlags) +import System.Glib.UTFString (peekUTFString) +-- {#import System.Gnome.VFS.Types#} +{#import System.Gnome.VFS.BasicTypes#} +import System.Gnome.VFS.Error +import Prelude hiding (error) + +cToEnum :: (Integral a, Enum b) => a -> b +cToEnum = toEnum . fromIntegral + +cFromEnum :: (Enum a, Integral b) => a -> b +cFromEnum = fromIntegral . fromEnum + +cToBool :: Integral a => a -> Bool +cToBool = toBool . fromIntegral + +cFromBool :: Integral a => Bool -> a +cFromBool = fromIntegral . fromBool + +cToFlags :: (Integral a, Flags b) => a -> [b] +cToFlags = toFlags . fromIntegral + +cFromFlags :: (Flags a, Integral b) => [a] -> b +cFromFlags = fromIntegral . fromFlags + +genericResultMarshal :: IO {# type GnomeVFSResult #} + -> IO a + -> IO b + -> IO a +genericResultMarshal cAction cSuccessAction cFailureAction = + do result <- liftM cToEnum $ cAction + case result of + Ok -> cSuccessAction + errorCode -> do cFailureAction + error result + +voidResultMarshal :: IO {# type GnomeVFSResult #} + -> IO () +voidResultMarshal cAction = + genericResultMarshal cAction (return ()) (return ()) + +newObjectResultMarshal :: (ForeignPtr obj -> obj) + -> (Ptr (Ptr obj) -> IO {# type GnomeVFSResult #}) + -> IO obj +newObjectResultMarshal objConstructor cNewObj = + alloca $ \cObjPtr -> + do poke cObjPtr nullPtr + genericResultMarshal (cNewObj cObjPtr) + (do cObj <- peek cObjPtr + assert (cObj /= nullPtr) $ return () + newObj <- newForeignPtr_ cObj + return $ objConstructor newObj) + (do cObj <- peek cObjPtr + assert (cObj == nullPtr) $ return ()) + +volumeOpCallbackMarshal :: VolumeOpSuccessCallback + -> VolumeOpFailureCallback + -> IO {# type GnomeVFSVolumeOpCallback #} +volumeOpCallbackMarshal successCallback failureCallback = + let cCallback :: CVolumeOpCallback + cCallback cSucceeded cError cDetailedError cUserData = + let succeeded = cToBool cSucceeded + cCallbackFunPtr = castPtrToFunPtr cUserData + in (flip finally) (freeHaskellFunPtr cCallbackFunPtr) $ + if succeeded + then assert (and [cError == nullPtr, cDetailedError == nullPtr]) $ + successCallback + else assert (and [cError /= nullPtr, cDetailedError /= nullPtr]) $ + do error <- peekUTFString cError + detailedError <- peekUTFString cDetailedError + failureCallback error detailedError + in makeVolumeOpCallback cCallback +foreign import ccall safe "wrapper" + makeVolumeOpCallback :: CVolumeOpCallback + -> IO {# type GnomeVFSVolumeOpCallback #} diff --git a/System/Gnome/VFS/Monitor.chs b/System/Gnome/VFS/Monitor.chs new file mode 100644 --- /dev/null +++ b/System/Gnome/VFS/Monitor.chs @@ -0,0 +1,99 @@ +{-# LANGUAGE CPP #-} +-- 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 Lesser General Public License +-- as published by the Free Software Foundation, either version 3 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this program. If not, see +-- . +-- +-- GnomeVFS, the C library which this Haskell library depends on, is +-- available under LGPL Version 2. The documentation included with +-- this library is based on the original GnomeVFS documentation, +-- Copyright (c) 2001 Seth Nickell . The +-- documentation is covered by the GNU Free Documentation License, +-- version 1.2. +-- +-- | Maintainer : gtk2hs-devel@lists.sourceforge.net +-- Stability : alpha +-- Portability : portable (depends on GHC) +module System.Gnome.VFS.Monitor ( + +-- * Types + MonitorHandle, + MonitorCallback, + +-- * Operations + monitorAdd, + monitorCancel + + ) where + +import Control.Monad (liftM) +import System.Glib.FFI +import System.Glib.UTFString +{#import System.Gnome.VFS.Marshal#} +-- {#import System.Gnome.VFS.Types#} +{#import System.Gnome.VFS.BasicTypes#} + +{# context lib = "gnomevfs" prefix = "gnome_vfs" #} + +type CMonitorCallback = Ptr MonitorHandle + -> CString + -> CString + -> {# type GnomeVFSMonitorEventType #} + -> {# type gpointer #} + -> IO () + +-- | Watch the object at @textURI@ for changes, and call @callback@ +-- when a change occurs. +monitorAdd :: String -- ^ @textURI@ - + -> MonitorType -- ^ @monitorType@ - + -> MonitorCallback -- ^ @callback@ - + -> IO MonitorHandle -- ^ a handle to the new monitor +monitorAdd textURI monitorType callback = + do cTestURI <- newUTFString textURI + let cMonitorType = cFromEnum monitorType + cCallback <- monitorCallbackMarshal callback + newObjectResultMarshal + (\cMonitorHandle -> + MonitorHandle (cMonitorHandle, cCallback)) + (\cMonitorHandlePtr -> + {# call monitor_add #} (castPtr cMonitorHandlePtr) cTestURI cMonitorType cCallback nullPtr) + +monitorCallbackMarshal :: MonitorCallback + -> IO {# type GnomeVFSMonitorCallback #} +monitorCallbackMarshal callback = + let cCallback :: CMonitorCallback + cCallback cHandle cMonitorURI cInfoURI cEventType cUserData = + do handle <- liftM (\cHandle -> MonitorHandle (cHandle, castPtrToFunPtr cUserData)) $ + newForeignPtr_ cHandle + monitorURI <- peekUTFString cMonitorURI + infoURI <- peekUTFString cInfoURI + let eventType = cToEnum cEventType + callback handle monitorURI infoURI eventType + in makeMonitorCallback cCallback +foreign import ccall safe "wrapper" + makeMonitorCallback :: CMonitorCallback + -> IO {# type GnomeVFSMonitorCallback #} + +-- | Cancels the monitor referred to by @monitorHandle@. +monitorCancel :: MonitorHandle -- ^ @monitorHandle@ + -> IO () +monitorCancel (MonitorHandle (cMonitorHandle, cCallback)) = + do freeHaskellFunPtr cCallback + withForeignPtr cMonitorHandle $ + voidResultMarshal . {# call monitor_cancel #} . castPtr diff --git a/System/Gnome/VFS/Ops.chs b/System/Gnome/VFS/Ops.chs new file mode 100644 --- /dev/null +++ b/System/Gnome/VFS/Ops.chs @@ -0,0 +1,311 @@ +{-# LANGUAGE CPP #-} +-- 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 Lesser General Public License +-- as published by the Free Software Foundation, either version 3 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this program. If not, see +-- . +-- +-- GnomeVFS, the C library which this Haskell library depends on, is +-- available under LGPL Version 2. The documentation included with +-- this library is based on the original GnomeVFS documentation, +-- Copyright (c) 2001 Seth Nickell . The +-- documentation is covered by the GNU Free Documentation License, +-- version 1.2. +-- +-- | Maintainer : gtk2hs-devel@lists.sourceforge.net +-- Stability : alpha +-- Portability : portable (depends on GHC) +module System.Gnome.VFS.Ops ( + +-- * Types + Handle, + Result(..), + OpenMode(..), + SeekPosition(..), + FilePermissions(..), + FileSize, + FileOffset, + +-- * I\/O Operations + open, + openURI, + create, + createURI, + close, +#if __GLASGOW_HASKELL__ >= 606 + read, + write, +#endif + seek, + tell, +#if GNOME_VFS_CHECK_VERSION(2,12,0) + forgetCache, +#endif + +-- * Truncation + truncate, + truncateURI, + truncateHandle, + +-- * File Information + getFileInfo, + getFileInfoURI, + getFileInfoFromHandle, + setFileInfo, + setFileInfoURI + + ) where + +#if __GLASGOW_HASKELL__ >= 606 && __GLASGOW_HASKELL__ < 608 +#define OLD_BYTESTRING +#endif + +import Control.Exception +import Control.Monad (liftM) +#if __GLASGOW_HASKELL__ >= 606 +import qualified Data.ByteString as BS (ByteString, useAsCStringLen) +#ifdef OLD_BYTESTRING +import qualified Data.ByteString.Base as BS (fromForeignPtr) +#else +import qualified Data.ByteString.Internal as BS (fromForeignPtr) +#endif +#endif +import Prelude hiding (read, truncate) +import System.Glib.FFI +import System.Glib.UTFString (withUTFString, peekUTFString) +-- {#import System.Gnome.VFS.Types#} +{#import System.Gnome.VFS.BasicTypes#} +{#import System.Gnome.VFS.FileInfo#} +{#import System.Gnome.VFS.Marshal#} + +{# context lib = "gnomevfs" prefix = "gnome_vfs" #} + +-- | Open the file at @textURI@. +open :: TextURI -- ^ @textURI@ - + -> OpenMode -- ^ @openMode@ - + -> IO Handle -- ^ a handle to the opened file +open textURI openMode = + let cOpenMode = cFromEnum openMode + in withUTFString textURI $ \cTextURI -> + newObjectResultMarshal Handle $ \cHandlePtr -> + {# call gnome_vfs_open #} (castPtr cHandlePtr) cTextURI cOpenMode + +-- | Open the file at @uri@. +openURI :: URI -- ^ @uri@ - + -> OpenMode -- ^ @openMode@ - + -> IO Handle -- ^ a handle to the opened file +openURI uri openMode = + let cOpenMode = cFromEnum openMode + in newObjectResultMarshal Handle $ \cHandlePtr -> + {# call open_uri #} (castPtr cHandlePtr) uri cOpenMode + +-- | Create a file at @textURI@. +create :: TextURI -- ^ @textURI@ - + -> OpenMode -- ^ @openMode@ - + -> Bool -- ^ @exclusive@ - + -> [FilePermissions] -- ^ @perm@ - + -> IO Handle -- ^ a handle to the created file +create textURI openMode exclusive perm = + let cOpenMode = cFromEnum openMode + cExclusive = fromBool exclusive + cPerm = cFromFlags perm + in withUTFString textURI $ \cTextURI -> + newObjectResultMarshal Handle $ \cHandlePtr -> + {# call gnome_vfs_create #} (castPtr cHandlePtr) cTextURI cOpenMode cExclusive cPerm + +-- | Create a file at @uri@. +createURI :: URI -- ^ @uri@ - + -> OpenMode -- ^ @openMode@ - + -> Bool -- ^ @exclusive@ - + -> [FilePermissions] -- ^ @perm@ - + -> IO Handle -- ^ a handle to the created file +createURI uri openMode exclusive perm = + let cOpenMode = cFromEnum openMode + cExclusive = fromBool exclusive + cPerm = cFromFlags perm + in newObjectResultMarshal Handle $ \cHandlePtr -> + {# call create_uri #} (castPtr cHandlePtr) uri cOpenMode cExclusive cPerm + +-- | Close a 'Handle'. +close :: Handle -- ^ @handle@ - + -> IO () +close handle = + voidResultMarshal $ {# call gnome_vfs_close #} handle + +#if __GLASGOW_HASKELL__ >= 606 +-- | Read data from a file. +read :: Handle -- ^ @handle@ - + -> FileSize -- ^ @bytes@ - + -> IO BS.ByteString -- ^ the data read from the file +read handle bytes = + let cBytes = fromIntegral bytes + in do buffer <- mallocForeignPtrBytes $ fromIntegral bytes + withForeignPtr buffer $ \cBuffer -> + alloca $ \cBytesReadPtr -> + genericResultMarshal + (do poke cBytesReadPtr 0 + {# call gnome_vfs_read #} handle cBuffer cBytes cBytesReadPtr) + (do bytesRead <- liftM fromIntegral $ peek cBytesReadPtr + assert (bytesRead /= 0 || cBytes == 0) $ return () + return $ BS.fromForeignPtr (castForeignPtr buffer) +#ifndef OLD_BYTESTRING + 0 +#endif + (fromIntegral bytes)) + (do bytesRead <- liftM fromIntegral $ peek cBytesReadPtr + assert (bytesRead == 0) $ return ()) + +-- | Write data to a file. +write :: Handle -- ^ @handle@ - + -> BS.ByteString -- ^ @byteString@ - + -> IO FileSize -- ^ the number of bytes actually written +write handle byteString = + BS.useAsCStringLen byteString $ \(cBuffer, bytes) -> + let cBytes = fromIntegral bytes + in alloca $ \cBytesWrittenPtr -> + genericResultMarshal + (do poke cBytesWrittenPtr 0 + {# call gnome_vfs_write #} handle (castPtr cBuffer) cBytes cBytesWrittenPtr) + (do bytesWritten <- liftM fromIntegral $ peek cBytesWrittenPtr + assert (bytesWritten /= 0 || cBytes == 0) $ return () + return bytesWritten) + (do bytesWritten <- liftM fromIntegral $ peek cBytesWrittenPtr + assert (bytesWritten == 0) $ return ()) +#endif + +-- | Seek to a position in a file. +seek :: Handle -- ^ @handle@ - + -> SeekPosition -- ^ @whence@ - + -> FileOffset -- ^ @offset@ - + -> IO () +seek handle whence offset = + let cWhence = cFromEnum whence + cOffset = fromIntegral offset + in voidResultMarshal $ {# call gnome_vfs_seek #} handle cWhence cOffset + +-- | Return the current position in the file. +tell :: Handle -- ^ @handle@ - + -> IO FileSize -- ^ the current position in the file +tell handle = + alloca $ \cOffsetReturnPtr -> + genericResultMarshal + (do poke cOffsetReturnPtr 0 + {# call gnome_vfs_tell #} handle cOffsetReturnPtr) + (liftM fromIntegral $ peek cOffsetReturnPtr) + (do cOffsetReturn <- peek cOffsetReturnPtr + assert (cOffsetReturn == 0) $ return ()) + +#if GNOME_VFS_CHECK_VERSION(2,12,0) +-- | Free any cache associated with the file opened on @handle@, +-- in the region of @size@ bytes starting at @offset@. +forgetCache :: Handle + -> FileOffset + -> FileSize + -> IO () +forgetCache handle offset size = + let cOffset = fromIntegral offset + cSize = fromIntegral size + in voidResultMarshal $ {# call forget_cache #} handle cOffset cSize +#endif + +-- | Truncate the file at @textURI@ to @length@ bytes. +truncate :: String + -> FileSize + -> IO () +truncate textURI length = + let cLength = fromIntegral length + in withUTFString textURI $ \cTextURI -> + voidResultMarshal $ {# call gnome_vfs_truncate #} cTextURI cLength + +-- | Truncate the file at @uri@ to @length@ bytes. +truncateURI :: URI + -> FileSize + -> IO () +truncateURI uri length = + let cLength = fromIntegral length + in voidResultMarshal $ {# call truncate_uri #} uri cLength + +-- | Truncate the file opened on @handle@ to @length@ bytes. +truncateHandle :: Handle + -> FileSize + -> IO () +truncateHandle handle length = + let cLength = fromIntegral length + in voidResultMarshal $ {# call truncate_handle #} handle cLength + +-- | Get the file information for the file at @textURI@. +getFileInfo :: String + -> [FileInfoOptions] + -> IO FileInfo +getFileInfo textURI options = + let cOptions = cFromFlags options + in withUTFString textURI $ \cTextURI -> + bracket {# call file_info_new #} + {# call file_info_unref #} + (\cFileInfo -> + genericResultMarshal + ({# call get_file_info #} cTextURI cFileInfo cOptions) + (peek $ castPtr cFileInfo) + (return ())) + +-- | Get the file information for the file at @uri@. +getFileInfoURI :: URI + -> [FileInfoOptions] + -> IO FileInfo +getFileInfoURI uri options = + let cOptions = cFromFlags options + in bracket {# call file_info_new #} + {# call file_info_unref #} + (\cFileInfo -> + genericResultMarshal + ({# call get_file_info_uri #} uri cFileInfo cOptions) + (peek $ castPtr cFileInfo) + (return ())) + +-- | Get the file information for the file opened on @handle@. +getFileInfoFromHandle :: Handle + -> [FileInfoOptions] + -> IO FileInfo +getFileInfoFromHandle handle options = + let cOptions = cFromFlags options + in bracket {# call file_info_new #} + {# call file_info_unref #} + (\cFileInfo -> + genericResultMarshal + ({# call get_file_info_from_handle #} handle cFileInfo cOptions) + (peek $ castPtr cFileInfo) + (return ())) + +-- | Set the file information for the file at @textURI@. +setFileInfo :: String + -> FileInfo + -> [SetFileInfoMask] + -> IO () +setFileInfo textURI info mask = + withUTFString textURI $ \cTextURI -> + with info $ \cInfo -> + voidResultMarshal $ {# call set_file_info #} cTextURI (castPtr cInfo) $ cFromFlags mask + +-- | Set the file information for the file at @uri@. +setFileInfoURI :: URI + -> FileInfo + -> [SetFileInfoMask] + -> IO () +setFileInfoURI uri info mask = + with info $ \cInfo -> + voidResultMarshal $ {# call set_file_info_uri #} uri (castPtr cInfo) $ cFromFlags mask diff --git a/System/Gnome/VFS/Signals.chs b/System/Gnome/VFS/Signals.chs new file mode 100644 --- /dev/null +++ b/System/Gnome/VFS/Signals.chs @@ -0,0 +1,77 @@ +{-# OPTIONS_HADDOCK hide #-} +-- -*-haskell-*- +-- -------------------- automatically generated file - do not edit ------------ +-- Callback installers for the GIMP Toolkit (GTK) Binding for Haskell +-- +-- Author : Axel Simon +-- +-- Created: 1 July 2000 +-- +-- Copyright (C) 2000-2005 Axel Simon +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 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 +-- Lesser General Public License for more details. +-- +-- #hide + +-- These functions are used to connect signals to widgets. They are auto- +-- matically created through HookGenerator.hs which takes a list of possible +-- function signatures that are included in the GTK sources (gtkmarshal.list). +-- +-- The object system in the second version of GTK is based on GObject from +-- GLIB. This base class is rather primitive in that it only implements +-- ref and unref methods (and others that are not interesting to us). If +-- the marshall list mentions OBJECT it refers to an instance of this +-- GObject which is automatically wrapped with a ref and unref call. +-- Structures which are not derived from GObject have to be passed as +-- BOXED which gives the signal connect function a possibility to do the +-- conversion into a proper ForeignPtr type. In special cases the signal +-- connect function use a PTR type which will then be mangled in the +-- user function directly. The latter is needed if a signal delivers a +-- pointer to a string and its length in a separate integer. +-- +module System.Gnome.VFS.Signals ( + module System.Glib.Signals, + + connect_OBJECT__NONE, + + ) where + +import Control.Monad (liftM) + +import System.Glib.FFI +import System.Glib.UTFString (peekUTFString) +import System.Glib.GError (failOnGError) +{#import System.Glib.Signals#} +{#import System.Glib.GObject#} +import Graphics.UI.GtkInternals + + +{#context lib="gtk" prefix="gtk" #} + + +-- Here are the generators that turn a Haskell function into +-- a C function pointer. The fist Argument is always the widget, +-- the last one is the user g_pointer. Both are ignored. + + +connect_OBJECT__NONE :: + (GObjectClass a', GObjectClass obj) => SignalName -> + ConnectAfter -> obj -> + (a' -> IO ()) -> + IO (ConnectId obj) +connect_OBJECT__NONE signal after obj user = + connectGeneric signal after obj action + where action :: Ptr GObject -> Ptr GObject -> IO () + action _ obj1 = + failOnGError $ + makeNewGObject (GObject, objectUnrefFromMainloop) (return obj1) >>= \obj1' -> + user (unsafeCastGObject obj1') + diff --git a/System/Gnome/VFS/Types.chs b/System/Gnome/VFS/Types.chs new file mode 100644 --- /dev/null +++ b/System/Gnome/VFS/Types.chs @@ -0,0 +1,140 @@ +{-# OPTIONS_HADDOCK hide #-} +-- -*-haskell-*- +-- -------------------- automatically generated file - do not edit ---------- +-- Object hierarchy for the GIMP Toolkit (GTK) Binding for Haskell +-- +-- Author : Axel Simon +-- +-- Copyright (C) 2001-2005 Axel Simon +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 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 +-- Lesser General Public License for more details. +-- +-- #hide + +-- | +-- Maintainer : gtk2hs-users@lists.sourceforge.net +-- Stability : provisional +-- Portability : portable (depends on GHC) +-- +-- This file reflects the Gtk+ object hierarchy in terms of Haskell classes. +-- +-- Note: the mk... functions were originally meant to simply be an alias +-- for the constructor. However, in order to communicate the destructor +-- of an object to objectNew, the mk... functions are now a tuple containing +-- Haskell constructor and the destructor function pointer. This hack avoids +-- changing all modules that simply pass mk... to objectNew. +-- +module System.Gnome.VFS.Types ( + + module Graphics.UI.GtkInternals, + Volume(Volume), VolumeClass, + toVolume, + mkVolume, unVolume, + castToVolume, gTypeVolume, + Drive(Drive), DriveClass, + toDrive, + mkDrive, unDrive, + castToDrive, gTypeDrive, + VolumeMonitor(VolumeMonitor), VolumeMonitorClass, + toVolumeMonitor, + mkVolumeMonitor, unVolumeMonitor, + castToVolumeMonitor, gTypeVolumeMonitor + ) where + +import Foreign.ForeignPtr (ForeignPtr, castForeignPtr, unsafeForeignPtrToPtr) +import Foreign.C.Types (CULong, CUInt) +import System.Glib.GType (GType, typeInstanceIsA) +import Graphics.UI.GtkInternals + +{# context lib="gtk" prefix="gtk" #} + +-- The usage of foreignPtrToPtr should be safe as the evaluation will only be +-- forced if the object is used afterwards +-- +castTo :: (GObjectClass obj, GObjectClass obj') => GType -> String + -> (obj -> obj') +castTo gtype objTypeName obj = + case toGObject obj of + gobj@(GObject objFPtr) + | typeInstanceIsA ((unsafeForeignPtrToPtr.castForeignPtr) objFPtr) gtype + -> unsafeCastGObject gobj + | otherwise -> error $ "Cannot cast object to " ++ objTypeName + + +-- ********************************************************************* Volume + +{#pointer *GnomeVFSVolume as Volume foreign newtype #} deriving (Eq,Ord) + +mkVolume = (Volume, objectUnrefFromMainloop) +unVolume (Volume o) = o + +class GObjectClass o => VolumeClass o +toVolume :: VolumeClass o => o -> Volume +toVolume = unsafeCastGObject . toGObject + +instance VolumeClass Volume +instance GObjectClass Volume where + toGObject = GObject . castForeignPtr . unVolume + unsafeCastGObject = Volume . castForeignPtr . unGObject + +castToVolume :: GObjectClass obj => obj -> Volume +castToVolume = castTo gTypeVolume "Volume" + +gTypeVolume :: GType +gTypeVolume = + {# call fun unsafe gnome_vfs_volume_get_type #} + +-- ********************************************************************** Drive + +{#pointer *GnomeVFSDrive as Drive foreign newtype #} deriving (Eq,Ord) + +mkDrive = (Drive, objectUnrefFromMainloop) +unDrive (Drive o) = o + +class GObjectClass o => DriveClass o +toDrive :: DriveClass o => o -> Drive +toDrive = unsafeCastGObject . toGObject + +instance DriveClass Drive +instance GObjectClass Drive where + toGObject = GObject . castForeignPtr . unDrive + unsafeCastGObject = Drive . castForeignPtr . unGObject + +castToDrive :: GObjectClass obj => obj -> Drive +castToDrive = castTo gTypeDrive "Drive" + +gTypeDrive :: GType +gTypeDrive = + {# call fun unsafe gnome_vfs_drive_get_type #} + +-- ************************************************************** VolumeMonitor + +{#pointer *GnomeVFSVolumeMonitor as VolumeMonitor foreign newtype #} deriving (Eq,Ord) + +mkVolumeMonitor = (VolumeMonitor, objectUnrefFromMainloop) +unVolumeMonitor (VolumeMonitor o) = o + +class GObjectClass o => VolumeMonitorClass o +toVolumeMonitor :: VolumeMonitorClass o => o -> VolumeMonitor +toVolumeMonitor = unsafeCastGObject . toGObject + +instance VolumeMonitorClass VolumeMonitor +instance GObjectClass VolumeMonitor where + toGObject = GObject . castForeignPtr . unVolumeMonitor + unsafeCastGObject = VolumeMonitor . castForeignPtr . unGObject + +castToVolumeMonitor :: GObjectClass obj => obj -> VolumeMonitor +castToVolumeMonitor = castTo gTypeVolumeMonitor "VolumeMonitor" + +gTypeVolumeMonitor :: GType +gTypeVolumeMonitor = + {# call fun unsafe gnome_vfs_volume_monitor_get_type #} + diff --git a/System/Gnome/VFS/URI.chs b/System/Gnome/VFS/URI.chs new file mode 100644 --- /dev/null +++ b/System/Gnome/VFS/URI.chs @@ -0,0 +1,403 @@ +{-# LANGUAGE CPP #-} +-- 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 Lesser General Public License +-- as published by the Free Software Foundation, either version 3 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this program. If not, see +-- . +-- +-- GnomeVFS, the C library which this Haskell library depends on, is +-- available under LGPL Version 2. The documentation included with +-- this library is based on the original GnomeVFS documentation, +-- Copyright (c) 2001 Seth Nickell . The +-- documentation is covered by the GNU Free Documentation License, +-- version 1.2. +-- +-- | Maintainer : gtk2hs-devel@lists.sourceforge.net +-- Stability : alpha +-- Portability : portable (depends on GHC) +module System.Gnome.VFS.URI ( + +-- * Types + URI, + ToplevelURI, + TextURI, + URIHideOptions(..), + +-- * Operations + uriFromString, + uriResolveRelative, +#if GNOME_VFS_CHECK_VERSION(2,16,0) + uriResolveSymbolicLink, +#endif + uriAppendString, + uriAppendPath, + uriAppendFileName, + uriToString, + uriIsLocal, + uriHasParent, + uriGetParent, + uriGetToplevel, + uriGetHostName, + uriGetScheme, + uriGetHostPort, + uriGetUserName, + uriGetPassword, + uriSetHostName, + uriSetHostPort, + uriSetUserName, + uriSetPassword, + uriEqual, + uriIsParent, + uriGetPath, + uriGetFragmentIdentifier, + uriExtractDirname, + uriExtractShortName, + uriExtractShortPathName, + uriListParse, + uriMakeFullFromRelative + ) where + +import Control.Monad (liftM) +{#import System.Gnome.VFS.Marshal#} +-- {#import System.Gnome.VFS.Types#} +{#import System.Gnome.VFS.BasicTypes#} +import System.Glib.FFI +import System.Glib.UTFString +{#import System.Glib.GList#} +import System.IO (FilePath) + +{# context lib = "gnomevfs" prefix = "gnome_vfs" #} + +-- | Create a new 'URI' from @textURI@. Unsupported and unsafe +-- methods are not allowed and will result in 'Nothing' being +-- returned. URL transforms are allowed. +uriFromString :: TextURI + -> Maybe URI +uriFromString textURI = + unsafePerformIO $ withUTFString textURI {# call uri_new #} >>= maybePeek newURI + +-- | Create a new uri from @relativeReference@, relative to +-- @base@. The resolution algorithm in some aspects follows RFC +-- 2396, section 5.2, but is not identical due to some extra +-- assumptions GnomeVFS makes about URIs. +-- +-- If relative_reference begins with a valid scheme identifier +-- followed by @\':\'@, it is assumed to refer to an absolute URI, and a +-- 'URI' is created from it using 'uriFromString'. +-- +-- Otherwise, depending on its precise syntax, it inherits some +-- aspects of the parent URI, but the parents' fragment and query +-- components are ignored. +-- +-- If relative_reference begins with @\"\/\/\"@, it only inherits the +-- base scheme; if it begins with @\'\/\'@ (i.e., it is an absolute +-- path reference), it inherits everything except the base +-- path. Otherwise, it replaces the part of base after the last +-- @\'\/\'@. +-- +-- Note: This function should not be used by application authors +-- unless they expect very distinct semantics. Instead, authors +-- should use 'uriAppendFileName', 'uriAppendPath', +-- 'uriAppendString' or 'uriResolveSymbolicLink'. +uriResolveRelative :: URI -- ^ @base@ - the base URI + -> String -- ^ @relativeReference@ - a string + -- representing a possibly relative + -- URI reference + -> Maybe URI -- ^ a new URI referring to + -- @relativeReference@, or 'Nothing' + -- if @relativeReference@ is + -- malformed. +uriResolveRelative base relativeReference = + unsafePerformIO $ (withUTFString relativeReference $ + {# call uri_resolve_relative #} base) >>= maybePeek newURI + +#if GNOME_VFS_CHECK_VERSION(2,16,0) +-- | Create a new uri from @symbolicLink@, relative to @base@. +-- +-- If symbolic_link begins with a @\'\/\'@, it replaces the path of base, +-- otherwise it is appended after the last @\'\/\'@ character of base. +uriResolveSymbolicLink :: URI + -> String + -> Maybe URI +uriResolveSymbolicLink base symbolicLink = + unsafePerformIO $ (withUTFString symbolicLink $ + {# call uri_resolve_symbolic_link #} base) >>= maybePeek newURI +#endif + +-- | Create a new URI obtained by appending @uriFragment@ to @uri@. This +-- will take care of adding an appropriate directory separator +-- between the end of @uri@ and the start of @uriFragment@ if +-- necessary. +-- +-- This function will return 'Nothing' if the resulting URI is not +-- valid. +uriAppendString :: URI -- ^ @uri@ - the base URI + -> String -- ^ @uriFragment@ - an escaped URI fragment + -> Maybe URI -- ^ the new URI +uriAppendString uri uriFragment = + unsafePerformIO $ (withUTFString uriFragment $ + {# call uri_append_string #} uri) >>= maybePeek newURI + +-- | Create a new uri obtained by appending @path@ to @uri@. This will +-- take care of adding an appropriate directory separator between +-- the end of @uri@ and the start of @path@ if necessary, as well as +-- escaping @path@ as necessary. +-- +-- This function will return 'Nothing' if the resulting URI is not +-- valid. +uriAppendPath :: URI -- ^ @uri@ - the base URI + -> FilePath -- ^ @path@ - a non-escaped file path + -> Maybe URI -- ^ the new URI +uriAppendPath uri path = + unsafePerformIO $ (withUTFString path $ + {# call uri_append_path #} uri) >>= maybePeek newURI + +-- | Create a new URI obtained by appending @fileName@ to @uri@. This +-- will take care of adding an appropriate directory separator +-- between the end of @uri@ and the start of @fileName@ if +-- necessary. @fileName@ might, for instance, be the result of a call +-- to 'System.Posix.Directory.readDirStream'. +-- +-- This function will return 'Nothing' if the resulting URI is not +-- valid. +uriAppendFileName :: URI + -> FilePath + -> Maybe URI +uriAppendFileName uri fileName = + unsafePerformIO $ (withUTFString fileName $ + {# call uri_append_file_name #} uri) >>= maybePeek newURI + +-- | Translate @uri@ into a printable string. The string will not +-- contain the URI elements specified by @hideOptions@. +-- +-- A @file:@ URI on Win32 might look like +-- @file:\/\/\/x:\/foo\/bar.txt@. Note that the part after +-- @file:\/\/@ is not a legal file name, you need to remove the @\/@ +-- in front of the drive letter. This function does that +-- automatically if @hideOptions@ specifies that the toplevel +-- method, user name, password, host name and host port should be +-- hidden. +-- +-- On the other hand, a @file:@ URI for a UNC path looks like +-- @file:\/\/\/\/server\/share\/foo\/bar.txt@, and in that case the part +-- after @file:\/\/@ is the correct file name. +uriToString :: URI -- ^ @uri@ - a URI + -> URIHideOptions -- ^ @hideOptions@ - the URI elements that should not be included in the resulting string + -> TextURI -- ^ the resulting string +uriToString uri hideOptions = + unsafePerformIO $ ({# call uri_to_string #} uri $ + cFromEnum hideOptions) >>= readUTFString + +-- | Check if @uri@ is a local URI. Note that the return value of this +-- function entirely depends on the method associated with +-- the URI. It is up to the method author to distinguish between +-- remote URIs and URIs referring to entities on the local computer. +-- +-- Warning, this can be slow, as it does I\/O to detect things like +-- NFS mounts. +uriIsLocal :: URI -- ^ @uri@ - + -> IO Bool -- ^ 'True' if @uri@ is local, 'False' otherwise +uriIsLocal uri = + liftM toBool $ {# call uri_is_local #} uri + +-- | Check whether @uri@ has a parent or not. +uriHasParent :: URI -- ^ @uri@ - + -> Bool -- ^ 'True' if @uri@ has a parent, 'False' otherwise +uriHasParent uri = + unsafePerformIO $ liftM toBool $ {# call uri_has_parent #} uri + +-- | Retrieve @uri@'s parent URI. +uriGetParent :: URI -- ^ @uri@ - + -> Maybe URI -- ^ the parent URI, or 'Nothing' if @uri@ has no parent +uriGetParent uri = + unsafePerformIO $ {# call uri_get_parent #} uri >>= maybePeek newURI + +-- | Retrieve @uri@'s toplevel URI. +uriGetToplevel :: URI -- ^ @uri@ - + -> ToplevelURI -- ^ the toplevel URI +uriGetToplevel uri = + unsafePerformIO $ {# call uri_get_toplevel #} uri >>= newToplevelURI + +-- | Retrieve the hostname for @uri@. +uriGetHostName :: URI -- ^ @uri@ - + -> Maybe String -- ^ the hostname, or 'Nothing' if @uri@ has no hostname +uriGetHostName uri = + unsafePerformIO $ {# call uri_get_host_name #} uri >>= (maybePeek peekUTFString) + +-- | Retrieve the scheme for @uri@. +uriGetScheme :: URI -- ^ @uri@ - + -> Maybe String -- ^ the scheme, or 'Nothing' if @uri@ has no scheme +uriGetScheme uri = + unsafePerformIO $ {# call uri_get_scheme #} uri >>= (maybePeek peekUTFString) + +-- | Retrieve the host port for @uri@. +uriGetHostPort :: URI -- ^ @uri@ - + -> Word -- ^ the host port, or @0@ if the default port + -- value for the specified toplevel access + -- method is used +uriGetHostPort uri = + unsafePerformIO $ liftM cToEnum $ {# call uri_get_host_port #} uri + +-- | Retrieve the user name for @uri@. +uriGetUserName :: URI -- ^ @uri@ - + -> Maybe String -- ^ the user name, or 'Nothing' if @uri@ has no user name +uriGetUserName uri = + unsafePerformIO $ {# call uri_get_user_name #} uri >>= (maybePeek peekUTFString) + +-- | Retrieve the password for @uri@. +uriGetPassword :: URI -- ^ @uri@ - + -> Maybe String -- ^ the password, or 'Nothing' if @uri@ has no password +uriGetPassword uri = + unsafePerformIO $ {# call uri_get_password #} uri >>= (maybePeek peekUTFString) + +marshalSet :: (URI -> a -> IO ()) + -> URI + -> a + -> URI +marshalSet setAction uri newVal = + unsafePerformIO $ do uri <- {# call uri_dup #} uri >>= newURI + setAction uri newVal + return uri + +-- | Create a new 'URI' using @uri@, replacing the host name by @hostName@. +uriSetHostName :: URI -- ^ @uri@ - + -> Maybe String -- ^ @hostName@ - the new hostname + -> URI -- ^ the resulting URI +uriSetHostName = + marshalSet $ \uri hostName -> + maybeWith withUTFString hostName $ {# call uri_set_host_name #} uri + +-- | Create a new 'URI' using @uri@, replacing the host port by @hostPort@. +-- +-- If @hostPort@ is @0@, use the default port for @uri@'s toplevel +-- access method. +uriSetHostPort :: URI -- ^ @uri@ - + -> Word -- ^ @hostPort@ - the new host port + -> URI -- ^ the resulting URI +uriSetHostPort = + marshalSet $ \uri hostPort -> + {# call uri_set_host_port #} uri $ cFromEnum hostPort + +-- | Create a new 'URI' using @uri@, replacing the user name by @userName@. +uriSetUserName :: URI -- ^ @uri@ - + -> Maybe String -- ^ @userName@ - the new user name + -> URI -- ^ the resulting URI +uriSetUserName = + marshalSet $ \uri userName -> + maybeWith withUTFString userName $ {# call uri_set_user_name #} uri + +-- | Create a new 'URI' using @uri@, replacing the password by @password@. +uriSetPassword :: URI -- ^ @uri@ - + -> Maybe String -- ^ @password@ - the new password + -> URI -- ^ the resulting URI +uriSetPassword = + marshalSet $ \uri password -> + maybeWith withUTFString password $ {# call uri_set_password #} uri + +-- | Compare two 'URI's for equality. +uriEqual :: URI -- ^ @a@ - + -> URI -- ^ @b@ - + -> Bool -- ^ 'True' if the URIs are the same, 'False' otherwise. +uriEqual a b = + unsafePerformIO $ liftM toBool $ {# call uri_equal #} a b + +-- | Check if @possibleChild@ is contained in @possibleParent@. If +-- @recursive@ is 'False', just try the immediate parent; otherwise +-- search up through the heirarchy. +uriIsParent :: URI -- ^ @possibleParent@ - + -> URI -- ^ @possibleChild@ - + -> Bool -- ^ @recursive@ - 'True' if parents should be + -- checked recursively, 'False' otherwise + -> Bool -- ^ 'True' if @possibleChild@ is contained in + -- @possibleParent@, otherwise 'False' +uriIsParent possibleParent possibleChild recursive = + unsafePerformIO $ liftM toBool $ + {# call uri_is_parent #} possibleParent possibleChild $ fromBool recursive + +-- | Retrieve the path name for @uri@. +uriGetPath :: URI -- ^ @uri@ - + -> Maybe FilePath -- ^ the path name, or 'Nothing' if @uri@ + -- has no path name +uriGetPath uri = + unsafePerformIO $ {# call uri_get_path #} uri >>= (maybePeek peekUTFString) + +-- | Retrieve the fragment identifier for @uri@. +uriGetFragmentIdentifier :: URI -- ^ @uri@ - + -> Maybe String -- ^ the fragment identifier, + -- or 'Nothing' if @uri@ + -- has no fragment + -- identifier +uriGetFragmentIdentifier uri = + unsafePerformIO $ {# call uri_get_fragment_identifier #} uri >>= (maybePeek peekUTFString) + +-- | Extract the name of the directory in which the file pointed to by +-- @uri@ is stored as a string. The string will end with a directory +-- separator. +uriExtractDirname :: URI -- ^ @uri@ - + -> Maybe FilePath -- ^ the directory name, or + -- 'Nothing' if @uri@ has no + -- directory name +uriExtractDirname uri = + unsafePerformIO $ {# call uri_extract_dirname #} uri >>= (maybePeek readUTFString) + + +-- | Retrieve base file name for @uri@, ignoring any trailing path +-- separators. This matches the XPG definition of basename, but not +-- 'System.FilePath.basename'. This is often useful when you want +-- the name of something that's pointed to by a URI, and don't care +-- whether the uri has a directory or file form. If @uri@ points to +-- the root of a domain, returns the host name. If there's no host +-- name, returns the path separator. +-- +-- See also: 'uriExtractShortPathName'. +uriExtractShortName :: URI -- ^ @uri@ - + -> String -- the unescaped short form of the name +uriExtractShortName uri = + unsafePerformIO $ {# call uri_extract_short_name #} uri >>= readUTFString + +-- | Retrieve base file name for @uri@, ignoring any trailing path +-- separators. This matches the XPG definition of basename, but not +-- 'System.FilePath.basename'. This is often useful when you want +-- the name of something that's pointed to by a URI, and don't care +-- whether the uri has a directory or file form. If @uri@ points to +-- the root of any domain, returns the path separator. +-- +-- See also: 'uriExtractShortName'. +uriExtractShortPathName :: URI -- ^ @uri@ - + -> String -- the +uriExtractShortPathName uri = + unsafePerformIO $ {# call uri_extract_short_path_name #} uri >>= readUTFString + +-- | Extracts a list of URIs from a standard @text\/uri-list@, such as +-- one would get on a drop operation. +uriListParse :: String -- ^ @uriList@ - a list of URIs, separated by newlines + -> [URI] -- ^ the list of URIs +uriListParse uriList = + unsafePerformIO $ do uriList <- withUTFString uriList $ \cURIList -> + {# call uri_list_parse #} cURIList >>= fromGList + sequence $ map newURI uriList + +-- | Returns a full URI given a full base URI, and a secondary URI +-- which may be relative. +uriMakeFullFromRelative :: String -- ^ @baseURI@ - + -> String -- ^ @relativeURI@ - + -> Maybe String -- ^ the resulting URI +uriMakeFullFromRelative baseURI relativeURI = + unsafePerformIO $ (withUTFString baseURI $ \cBaseURI -> + withUTFString relativeURI $ \cRelativeURI -> + {# call uri_make_full_from_relative #} cBaseURI cRelativeURI) >>= maybePeek readUTFString diff --git a/System/Gnome/VFS/Util.chs b/System/Gnome/VFS/Util.chs new file mode 100644 --- /dev/null +++ b/System/Gnome/VFS/Util.chs @@ -0,0 +1,329 @@ +{-# LANGUAGE CPP #-} +-- 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 Lesser General Public License +-- as published by the Free Software Foundation, either version 3 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this program. If not, see +-- . +-- +-- GnomeVFS, the C library which this Haskell library depends on, is +-- available under LGPL Version 2. The documentation included with +-- this library is based on the original GnomeVFS documentation, +-- Copyright (c) 2001 Seth Nickell . The +-- documentation is covered by the GNU Free Documentation License, +-- version 1.2. +-- +-- | Maintainer : gtk2hs-devel@lists.sourceforge.net +-- Stability : alpha +-- Portability : portable (depends on GHC) +module System.Gnome.VFS.Util ( + +-- * String Formatting Functions + formatFileSizeForDisplay, + formatURIForDisplay, + +-- * External Applications + urlShow, + urlShowWithEnv, + isExecutableCommandString, + +-- * String Escaping Functions + escapeString, + escapePathString, + escapeHostAndPathString, + escapeSlashes, + escapeSet, + unescapeString, + unescapeStringForDisplay, + +-- * 'TextURI' and Path Functions + makeURICanonical, + makeURICanonicalStripFragment, + makePathNameCanonical, + makeURIFromInput, + makeURIFromInputWithDirs, + makeURIFromShellArg, + expandInitialTilde, + getLocalPathFromURI, + getURIFromLocalPath, + iconPathFromFilename, + getVolumeFreeSpace, + urisMatch, + getURIScheme, + +-- * Miscellaneous Functions + isPrimaryThread, + openFD, + + ) where + +import Control.Exception (assert) +import Control.Monad (liftM) +import System.Posix.Types (Fd) +import System.Glib.FFI +import System.Glib.UTFString +-- {#import System.Gnome.VFS.Types#} +{#import System.Gnome.VFS.BasicTypes#} +{#import System.Gnome.VFS.Marshal#} + +{# context lib = "gnomevfs" prefix = "gnome_vfs" #} + +-- | Formats @size@ so that it is easy for the user to read. Gives the +-- size in bytes, kilobytes, megabytes or gigabytes, choosing +-- whatever is appropriate. +formatFileSizeForDisplay :: FileSize -- ^ @size@ - the file size to be formatted + -> String -- ^ the formatted size ready for display +formatFileSizeForDisplay size = + unsafePerformIO $ {# call format_file_size_for_display #} (fromIntegral size) >>= readUTFString + +-- | Filter, modify, unescape, and change @textURI@ to make it appropriate +-- for display to users. +-- +-- Rules: A @file:@ URI without fragments should appear as a local +-- path. A @file:@ URI with fragments should appear as @file:uri@. All +-- other URIs appear as expected. +formatURIForDisplay :: TextURI -- ^ @textURI@ - the URI to format + -> Maybe String -- ^ the formatted URI ready for display +formatURIForDisplay textURI = + unsafePerformIO $ withUTFString textURI {# call format_uri_for_display #} >>= maybePeek readUTFString + +-- | Launches the default application or component associated with the +-- given URL. +urlShow :: String -- ^ @url@ - the URL to launch an application for + -> IO () +urlShow url = + voidResultMarshal $ withUTFString url {# call url_show #} + +-- | Like 'urlShow', but using the specified environment variables. +urlShowWithEnv :: String -- ^ @url@ - the URL to launch an application for + -> [String] -- ^ @env@ - a list of strings @[\"VARIABLE1=value1\", \"VARIABLE2=value2\", ...]@ + -> IO () +urlShowWithEnv url env = + voidResultMarshal $ withUTFStringArray env $ \cEnv -> + withUTFString url $ \cURL -> + {# call url_show_with_env #} cURL cEnv + +marshalPureString :: IO CString + -> String +marshalPureString cAction = + unsafePerformIO $ cAction >>= readUTFString + +marshalPureMaybeString :: IO CString + -> Maybe String +marshalPureMaybeString cAction = + unsafePerformIO $ cAction >>= maybePeek readUTFString + +-- | Escapes @string@, replacing any and all special characters with +-- equivalent escape sequences. +escapeString :: String -- ^ @string@ - the string to be escaped + -> String -- the escaped string +escapeString string = + marshalPureString $ withUTFString string {# call escape_string #} + +-- | Escapes path, replacing only special characters that would not be +-- found in paths (so @\'\/\'@, @\'&\'@, and @\'=\'@ will not be escaped by this +-- function). +escapePathString :: FilePath -- ^ @path@ - the path string to be escaped + -> String -- ^ the escaped string +escapePathString path = + marshalPureString $ withUTFString path {# call escape_path_string #} + +-- | Escapes path, replacing only special characters that would not be +-- found in a path or host name (so @\'\/\'@, @\'&\'@, @\'=\'@, @\':\'@ and @\'\@\'@ will +-- not be escaped by this function). +escapeHostAndPathString :: FilePath -- ^ @path@ - the path to be escaped + -> String -- ^ the escaped string +escapeHostAndPathString path = + marshalPureString $ withUTFString path {# call escape_host_and_path_string #} + +-- | Escapes only @\'\/\'@ and @\'%\'@ characters in @string@, replacing +-- them with their escape sequence equivalents. +escapeSlashes :: String -- ^ @string@ - the string to be escaped + -> String -- ^ the escaped string +escapeSlashes string = + marshalPureString $ withUTFString string {# call escape_slashes #} + +-- | Escapes the characters listed in @matchSet@ in @string@. +escapeSet :: String -- ^ @string@ - the string to be escaped + -> String -- ^ @matchSet@ - the characters to escape + -> String -- ^ the escaped string +escapeSet string matchSet = + marshalPureString $ withUTFString matchSet $ \cMatchSet -> + withUTFString string $ \cString -> + {# call escape_set #} cString cMatchSet + +-- | Decodes escaped characters (i.e., @%xx@ sequences) in +-- @escapedString@. Characters are decoded in @%xx@ form, where +-- @xx@ is the hex code for an ASCII character. +unescapeString :: String -- @string@ - the string to be unescaped + -> String -- @illegalCharacters@ - the characters that must not be escaped + -> String -- ^ the unescaped string +unescapeString escapedString illegalCharacters = + marshalPureString $ withUTFString illegalCharacters $ \cIllegalCharacters -> + withUTFString escapedString $ \cEscapedString -> + {# call unescape_string #} cEscapedString cIllegalCharacters + +-- | Standardizes the format of @uri@, so that it can be used later +-- in other functions that expect a canonical URI. +makeURICanonical :: TextURI -- ^ @textURI@ - an absolute or relative URI; it may have a scheme + -> Maybe TextURI -- ^ the canonical representation of the URI +makeURICanonical textURI = + unsafePerformIO $ withUTFString textURI {# call make_uri_canonical #} >>= maybePeek readUTFString + +-- | Returns a canonicalized URI. If @uri@ contains a fragment +-- (anything after a @\'#\'@), it is stripped off, and the resulting +-- URI is made canonical. +makeURICanonicalStripFragment :: TextURI -- ^ @textURI@ - the URI to canonicalize + -> Maybe TextURI -- ^ the canonical representation of the URI +makeURICanonicalStripFragment textURI = + unsafePerformIO $ withUTFString textURI {# call make_uri_canonical_strip_fragment #} >>= maybePeek readUTFString + + +-- | Returns a canonicalized path name. +makePathNameCanonical :: FilePath -- ^ @pathName@ - the path name to canonicalize + -> Maybe TextURI -- ^ the canonicalized path name +makePathNameCanonical pathName = + unsafePerformIO $ withUTFString pathName {# call make_path_name_canonical #} >>= maybePeek readUTFString + +-- | Takes a user input path\/URI and makes a valid URI out of it. +-- +-- This function is the reverse of 'formatURIForDisplay'. +makeURIFromInput :: String -- ^ @location@ - the input to try to parse + -> Maybe TextURI -- ^ the resulting URI, or 'Nothing' if @location@ is invalid +makeURIFromInput location = + unsafePerformIO $ withUTFString location {# call make_uri_from_input #} >>= maybePeek readUTFString + +-- | Determine a fully qualified URI from a relative or absolute input +-- path. The directories specified by @dirs@ are searched when the +-- path is relative. +makeURIFromInputWithDirs :: FilePath -- ^ @location@ - the relative or absolute input path to resolve + -> [MakeURIDirs] -- ^ @dirs@ - the directories to search + -> IO TextURI -- ^ the resulting URI +makeURIFromInputWithDirs location dirs = + (withUTFString location $ flip {# call make_uri_from_input_with_dirs #} $ cFromFlags dirs) >>= readUTFString + +-- | Similar to 'makeURIFromInput', except: +-- +-- 1. guesses relative paths instead of HTTP domains +-- +-- 2. doesn\'t bother stripping leading\/trailing white space +-- +-- 3. doesn\'t bother with tilde expansion -- that\'s done by the shell +makeURIFromShellArg :: String + -> String +makeURIFromShellArg uri = + unsafePerformIO $ withUTFString uri {# call make_uri_from_shell_arg #} >>= readUTFString + +-- | If @path@ begins with a tilde, representing the user's home +-- directory, expand it to the actual directory. +expandInitialTilde :: String + -> IO String +expandInitialTilde path = + withUTFString path {# call expand_initial_tilde #} >>= readUTFString + +-- | Similar to @unescapeString@, but returns something +-- semi-intelligible to the user, even upon receiving traumatic +-- input such as @00@ or URIs in bad form. +-- +-- WARNING: You should never use this function on a whole URI! It +-- unescapes reserved characters, and can result in a mangled URI +-- that can not be re-entered. For example, it unescapes @\'#\'@, @\'&\'@ and +-- @\'?\'@, which have special meanings in URI strings. +unescapeStringForDisplay :: String + -> String +unescapeStringForDisplay escaped = + marshalPureString $ withUTFString escaped {# call unescape_string_for_display #} + +-- | Create a local path for a uri. +-- +-- If @uri@ is not a @file:\/\/\/@ URI, or it contains a fragment +-- identifier or is chained, this function returns 'Nothing'. +getLocalPathFromURI :: TextURI -- ^ the URI to convert + -> Maybe FilePath -- ^ the resulting path +getLocalPathFromURI uri = + marshalPureMaybeString $ withUTFString uri {# call get_local_path_from_uri #} + +-- | Returns a @file:\/\/\/@ URI for the local path @localFullPath@, +-- such as a path provided by +-- 'Graphics.UI.Gtk.Selectors.FileChooser.fileChooserGetFilename'. The +-- resulting URI may be provided, for instance, to +-- 'System.Gnome.VFS.URI.uriFromString'. +-- +-- On Windows @localFullPath@ should be in the UTF-8 encoding, and +-- can start with a drive letter, but doesn't have to. +getURIFromLocalPath :: FilePath -- ^ @localFullPath@ - + -> TextURI -- ^ the resulting URI +getURIFromLocalPath localFullPath = + marshalPureString $ withUTFString localFullPath {# call get_uri_from_local_path #} + +-- | Checks if @commandString@ starts with the full path of an +-- executable file or an executable in the system path. +isExecutableCommandString :: String -- ^ @commandString@ - + -> IO Bool -- 'True' is @commandString@ is an executable command string, otherwise 'False' +isExecutableCommandString commandString = + liftM toBool $ withUTFString commandString {# call is_executable_command_string #} + +-- | Stores the amount of free space in bytes on @uri@'s volume in +-- | size. +getVolumeFreeSpace :: URI -- ^ @uri@ - a URI to a file on a volume + -> IO FileSize -- ^ the free space in bytes on the volume +getVolumeFreeSpace uri = + alloca $ \cFileSizePtr -> + genericResultMarshal ({# call get_volume_free_space #} uri cFileSizePtr) + (liftM fromIntegral $ peek cFileSizePtr) + (do cFileSize <- peek cFileSizePtr + assert (cFileSize == 0) $ return ()) + +-- | Returns the icon path for @filename@. Example: +-- +-- @'iconPathFromFilename' \"nautilus\/nautilus-desktop.png\"@ will +-- return a string forming the full path of the file +-- @nautilus-desktop.png@, i.e. +-- @${prefix}\/share\/pixmaps\/nautilus\/nautilus-desktop.png@. +iconPathFromFilename :: String -- ^ @filename@ - a relative or absolute pathname + -> IO String -- ^ the absolute path to the icon file +iconPathFromFilename filename = + withUTFString filename {# call icon_path_from_filename #} >>= readUTFString + +-- | Check if the current thread is the thread with the main glib +-- event loop. +isPrimaryThread :: IO Bool -- ^ 'True' if the current thread is the + -- thread with the main glib event loop, + -- otherwise 'False' +isPrimaryThread = + liftM toBool {# call is_primary_thread #} + +-- | Retrieves the scheme used in @uri@. +getURIScheme :: TextURI -- ^ @uri@ - + -> Maybe String -- ^ the scheme used in @uri@, or 'Nothing' if @uri@ does not use a scheme +getURIScheme uri = + marshalPureMaybeString $ withUTFString uri {# call get_uri_scheme #} + +-- | Compare two URIs. +urisMatch :: TextURI -- ^ @uri1@ - + -> TextURI -- ^ @uri2@ - + -> Bool -- ^ 'True' if the URIs are the same, 'False' otherwise. +urisMatch uri1 uri2 = + unsafePerformIO $ liftM toBool $ withUTFString uri1 $ \cURI1 -> + withUTFString uri2 $ {# call uris_match #} cURI1 + +-- | Convert an open unix file descriptor into a 'Handle' object. +openFD :: Fd -- ^ @filedes@ - the file descriptor to use + -> IO Handle -- ^ the returned handle +openFD filedes = + newObjectResultMarshal Handle $ \cHandlePtr -> + {# call open_fd #} (castPtr cHandlePtr) $ fromIntegral filedes diff --git a/System/Gnome/VFS/Volume.chs b/System/Gnome/VFS/Volume.chs new file mode 100644 --- /dev/null +++ b/System/Gnome/VFS/Volume.chs @@ -0,0 +1,322 @@ +{-# LANGUAGE CPP #-} +-- 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 Lesser General Public License +-- as published by the Free Software Foundation, either version 3 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this program. If not, see +-- . +-- +-- GnomeVFS, the C library which this Haskell library depends on, is +-- available under LGPL Version 2. The documentation included with +-- this library is based on the original GnomeVFS documentation, +-- Copyright (c) 2001 Seth Nickell . The +-- documentation is covered by the GNU Free Documentation License, +-- version 1.2. +-- +-- | Maintainer : gtk2hs-devel@lists.sourceforge.net +-- Stability : alpha +-- Portability : portable (depends on GHC) +module System.Gnome.VFS.Volume ( + +-- * Types + -- | An abstraction for a mounted filesystem or network location. + Volume, + VolumeClass, + VolumeID, + -- | Safely cast an object to a 'Volume'. + castToVolume, + +-- * Volume Operations + volumeCompare, + volumeEject, + volumeGetActivationURI, + volumeGetDevicePath, + volumeGetDeviceType, + volumeGetDisplayName, + volumeGetDrive, + volumeGetFilesystemType, +#if GNOME_VFS_CHECK_VERSION(2,8,0) + volumeGetHalUDI, +#endif + volumeGetIcon, + volumeGetID, + volumeGetVolumeType, + volumeHandlesTrash, + volumeIsMounted, + volumeIsReadOnly, + volumeIsUserVisible, + volumeUnmount + + ) where + +import Control.Exception +import Control.Monad (liftM) +import System.Glib.UTFString +import System.Glib.FFI +{#import System.Gnome.VFS.Marshal#} +{#import System.Gnome.VFS.Types#} +{#import System.Gnome.VFS.BasicTypes#} + +{# context lib = "gnomevfs" prefix = "gnome_vfs" #} + +-- | Compares two 'Volume' objects @a@ and @b@. Two 'Volume' +-- objects referring to different volumes are guaranteed to not +-- return 'EQ' when comparing them. If they refer to the same volume '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 volumes (ZIP, floppy) +-- +-- * Optical volumes (CD, DVD) +-- +-- * External volumes (USB sticks, music players) +-- +-- * Mounted hard disks +-- +-- * Network mounts +-- +-- * Other volumes +-- +-- Afterwards, the display name of @a@ and @b@ is compared using a +-- locale-sensitive sorting algorithm. +-- +-- If two volumes have the same display name, their unique ID is +-- compared which can be queried using 'volumeGetID'. +volumeCompare :: (VolumeClass volume1, VolumeClass volume2) + => volume1 + -> volume2 + -> IO Ordering +volumeCompare a b = + do result <- liftM fromIntegral $ {# call volume_compare #} (castToVolume a) (castToVolume b) + let ordering | result < 0 = LT + | result > 0 = GT + | otherwise = EQ + return ordering + +-- Requests ejection of a 'Volume'. +-- +-- Before the unmount operation is executed, the +-- 'Volume' object's @pre-unmount@ signal is emitted. +-- +-- If the volume is a mount point, i.e. its type is +-- 'VolumeTypeMountpoint', it is unmounted, and if it refers to a +-- disk, it is also ejected. +-- +-- If the volume is a special VFS mount, i.e. its type is +-- 'VolumeTypeMount', it is ejected. +-- +-- If the volume is a connected server, it is removed from the list of +-- connected servers. +-- +-- Otherwise, no further action is done. +volumeEject :: VolumeClass volume + => volume -- ^ @volume@ - the volume to eject + -> VolumeOpSuccessCallback -- ^ @successCallback@ - the + -- callback to call once + -- the operation has + -- completed successfully + -> VolumeOpFailureCallback -- ^ @failureCallback@ - the + -- callback to call if the + -- operation fails + -> IO () +volumeEject volume successCallback failureCallback = + do cCallback <- volumeOpCallbackMarshal successCallback failureCallback + {# call volume_eject #} (castToVolume volume) cCallback $ castFunPtrToPtr cCallback + +marshalString cAction volume = + cAction (castToVolume volume) >>= readUTFString +marshalMaybeString cAction volume = + cAction (castToVolume volume) >>= maybePeek readUTFString + +-- | Returns the activation URI of @volume@. +-- +-- The returned URI usually refers to a valid location. You can +-- check the validity of the location by calling +-- 'System.Gnome.VFS.URI.uriFromString' with the URI, and checking +-- whether the return value is not 'Nothing'. +volumeGetActivationURI :: VolumeClass volume + => volume -- ^ @volume@ - the volume to query + -> IO TextURI -- ^ the volume's activation URI. +volumeGetActivationURI = + marshalString {# call volume_get_activation_uri #} + +-- | Returns the device path of a 'Volume' object. +-- +-- For HAL volumes, this returns the value of the volume's +-- @block.device@ key. For UNIX mounts, it returns the @mntent@'s +-- @mnt_fsname@ entry. +-- +-- Otherwise, it returns 'Nothing'. +volumeGetDevicePath :: VolumeClass volume => + volume -- ^ @volume@ - the volume object to query + -> IO String -- ^ the volume's device path +volumeGetDevicePath = + marshalString {# call volume_get_device_path #} + +-- | Returns the 'DeviceType' of a 'Volume' object. +volumeGetDeviceType :: VolumeClass volume => + volume -- ^ @volume@ - the volume object to query + -> IO DeviceType -- the volume's device type +volumeGetDeviceType volume = + liftM cToEnum $ {# call volume_get_device_type #} (castToVolume volume) + +-- | Returns the display name of a 'Volume' object. +volumeGetDisplayName :: VolumeClass volume => + volume -- ^ @volume@ - the volume object to query + -> IO String -- ^ the volume's display name +volumeGetDisplayName = + marshalString {# call volume_get_display_name #} + +-- | Returns the 'Drive' that @volume@ is on. +volumeGetDrive :: VolumeClass volume => + volume -- ^ @volume@ - the volume object to query + -> IO Drive -- ^ the containing drive +volumeGetDrive volume = + {# call volume_get_drive #} (castToVolume volume) >>= newDrive + +-- | Returns a string describing the file system on @volume@, or +-- 'Nothing' if no information on the underlying file system is +-- available. +-- +-- The file system may be used to provide special functionality that +-- depends on the file system type, for instance to determine +-- whether trashing is supported (cf. 'volumeHandlesTrash'). +-- +-- For HAL mounts, this returns the value of the @\"volume.fstype\"@ +-- key, for traditional UNIX mounts it is set to the mntent's +-- mnt_type key, for connected servers, 'Nothing' is returned. +volumeGetFilesystemType :: VolumeClass volume => + volume -- ^ @volume@ - the + -- volume object to query + -> IO (Maybe String) -- ^ a string describing + -- the filesystem type, + -- or 'Nothing' if no + -- information is + -- available +volumeGetFilesystemType = + marshalMaybeString {# call volume_get_filesystem_type #} + +#if GNOME_VFS_CHECK_VERSION(2,8,0) +-- | Returns the HAL UDI of a 'Volume' object. +-- +-- For HAL volumes, this matches the value of the @info.udi@ key, +-- for other volumes it is 'Nothing'. +volumeGetHalUDI :: VolumeClass volume => + volume -- ^ @volume@ - the volume object to query + -> IO (Maybe String) -- ^ the volume's HAL UDI +volumeGetHalUDI = + marshalMaybeString {# call volume_get_hal_udi #} +#endif + +-- | Returns the icon filename for a 'Volume' object. +volumeGetIcon :: VolumeClass volume => + volume -- ^ @volume@ - a volume object + -> IO FilePath -- ^ the icon that should be used for this volume +volumeGetIcon = + marshalString {# call volume_get_icon #} + +-- | Returns a unique identifier for a 'Volume' object. +volumeGetID :: VolumeClass volume => + volume -- ^ @volume@ - a volume object + -> IO VolumeID -- ^ a unique identifier for the volume +volumeGetID volume = + {# call volume_get_id #} (castToVolume volume) + +-- | Returns the volume type of @volume@. +volumeGetVolumeType :: VolumeClass volume => + volume -- ^ @volume@ - the volume object to query + -> IO VolumeType -- ^ the volume's volume type +volumeGetVolumeType volume = + liftM cToEnum $ {# call volume_get_volume_type #} (castToVolume volume) + +marshalBool cAction volume = + liftM toBool $ cAction (castToVolume volume) + +-- | Returns whether the file system on a volume supports trashing of +-- files. +-- +-- If the volume has an AutoFS file system (i.e., +-- 'volumeGetDeviceType' returns 'DeviceTypeAutofs'), or if the +-- volume is mounted read-only (i.e., 'volumeIsReadOnly' returns +-- 'True'), it is assumed to not support trashing of files. +-- +-- Otherwise, if the volume provides file system information, it is +-- determined whether the file system supports trashing of +-- files. +volumeHandlesTrash :: VolumeClass volume => + volume -- ^ @volume@ - + -> IO Bool -- ^ 'True' if the volume handles trash, otherwise 'False' +volumeHandlesTrash = + marshalBool {# call volume_handles_trash #} + +-- | Returns whether the file system on a volume is currently mounted. +-- +-- For HAL volumes, this reflects the value of the +-- @\"volume.is_mounted\"@ key, for traditional UNIX mounts and +-- connected servers, 'True' is returned, because their existence +-- implies that they are mounted. +volumeIsMounted :: VolumeClass volume => + volume -- ^ @volume@ - + -> IO Bool -- ^ 'True' if the volume is mounted, otherwise 'False' +volumeIsMounted = + marshalBool {# call volume_is_mounted #} + +-- | Returns whether the file system on a volume is read-only. +-- +-- For HAL volumes, the @\"volume.is_mounted_read_only\"@ key is +-- authoritative, for traditional UNIX mounts it returns TRUE if the +-- mount was done with the @\"ro\"@ option. For servers, 'False' is +-- returned. +volumeIsReadOnly :: VolumeClass volume => + volume -- ^ @volume@ - + -> IO Bool -- ^ 'True' if the volume is read-only, otherwise 'False' +volumeIsReadOnly = + marshalBool {# call volume_is_read_only #} + +-- | Returns a 'Bool' for whether a volume is user-visible. This should +-- be used by applications to determine whether the volume should be +-- listed in user interfaces listing available volumes. +volumeIsUserVisible :: VolumeClass volume => + volume -- @volume@ - + -> IO Bool -- ^ 'True' if the volume is user visible, otherwise 'False' +volumeIsUserVisible = + marshalBool {# call volume_is_user_visible #} + +-- Requests unmount of a 'Volume'. +-- +-- Note that 'volumeUnmount' may also unvoke 'volumeEject', if +-- @volume@ signals that it should be ejected when it is unmounted. +-- This may be true for CD-ROMs, USB sticks, and other devices, +-- depending on the backend providing the volume. +volumeUnmount :: VolumeClass volume + => volume -- ^ @volume@ - the volume to eject + -> VolumeOpSuccessCallback -- ^ @successCallback@ - the + -- callback to call once + -- the operation has + -- completed successfully + -> VolumeOpFailureCallback -- ^ @failureCallback@ - the + -- callback to call if the + -- operation fails + -> IO () +volumeUnmount volume successCallback failureCallback = + do cCallback <- volumeOpCallbackMarshal successCallback failureCallback + {# call volume_unmount #} (castToVolume volume) cCallback $ castFunPtrToPtr cCallback diff --git a/System/Gnome/VFS/VolumeMonitor.chs b/System/Gnome/VFS/VolumeMonitor.chs new file mode 100644 --- /dev/null +++ b/System/Gnome/VFS/VolumeMonitor.chs @@ -0,0 +1,174 @@ +{-# LANGUAGE CPP #-} +-- 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 Lesser General Public License +-- as published by the Free Software Foundation, either version 3 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this program. If not, see +-- . +-- +-- GnomeVFS, the C library which this Haskell library depends on, is +-- available under LGPL Version 2. The documentation included with +-- this library is based on the original GnomeVFS documentation, +-- Copyright (c) 2001 Seth Nickell . The +-- documentation is covered by the GNU Free Documentation License, +-- version 1.2. +-- +-- | Maintainer : gtk2hs-devel@lists.sourceforge.net +-- Stability : alpha +-- Portability : portable (depends on GHC) +module System.Gnome.VFS.VolumeMonitor ( + +-- * Types + + -- | An object that monitors volume mounts and unmounts. + VolumeMonitor, + VolumeMonitorClass, + +-- * Values + volumeMonitor, + +-- * Operations + volumeMonitorGetConnectedDrives, + volumeMonitorGetDriveByID, + volumeMonitorGetMountedVolumes, + volumeMonitorGetVolumeByID, + volumeMonitorGetVolumeForPath, + + onVolumeMonitorVolumeMounted, + afterVolumeMonitorVolumeMounted, + onVolumeMonitorVolumePreUnmount, + afterVolumeMonitorVolumePreUnmount, + onVolumeMonitorVolumeUnmounted, + afterVolumeMonitorVolumeUnmounted + + ) where + +import Control.Exception +import Control.Monad (liftM) +import System.Glib.FFI +import System.Glib.GList (readGList) +import System.Glib.UTFString +import System.Gnome.VFS.Marshal +{#import System.Gnome.VFS.Types#} +{#import System.Gnome.VFS.Signals#} +{#import System.Gnome.VFS.BasicTypes#} +import System.IO (FilePath) + +{# context lib = "gnomevfs" prefix = "gnome_vfs" #} + +-- | The global volume monitor object. +volumeMonitor :: VolumeMonitor +volumeMonitor = unsafePerformIO $ {# call get_volume_monitor #} >>= wrapVolumeMonitor + +-- | Returns a list of all drives connected to the machine. +volumeMonitorGetConnectedDrives :: VolumeMonitorClass volumeMonitor => + volumeMonitor -- ^ @volumeMonitor@ - the volume monitor + -> IO [Drive] -- ^ the drives connected to the machine +volumeMonitorGetConnectedDrives volumeMonitor = + {# call volume_monitor_get_connected_drives #} (castToVolumeMonitor volumeMonitor) >>= + readGList >>= mapM newDrive + +-- | Try to find the 'Drive' with ID @id@. +volumeMonitorGetDriveByID :: VolumeMonitorClass volumeMonitor => + volumeMonitor -- ^ @volumeMonitor@ - the volume monitor + -> DriveID -- ^ @id@ - the drive ID + -> IO (Maybe Drive) -- ^ the requested + -- drive, or 'Nothing' + -- if no drive with + -- that ID could be + -- found +volumeMonitorGetDriveByID volumeMonitor id = + {# call volume_monitor_get_drive_by_id #} (castToVolumeMonitor volumeMonitor) id >>= + maybePeek newDrive + +-- | Returns a list of all volumes currently mounted on the machine. +volumeMonitorGetMountedVolumes :: VolumeMonitorClass volumeMonitor => + volumeMonitor -- ^ @volumeMonitor@ - the volume monitor + -> IO [Volume] -- ^ the volumes + -- currently mounted + -- on the machine +volumeMonitorGetMountedVolumes volumeMonitor = + {# call volume_monitor_get_mounted_volumes #} (castToVolumeMonitor volumeMonitor) >>= + readGList >>= mapM newVolume + +-- | Try to find the 'Volume' with ID @id@. +volumeMonitorGetVolumeByID :: VolumeMonitorClass volumeMonitor => + volumeMonitor -- ^ @volumeMonitor@ - the volume monitor + -> VolumeID -- ^ @id@ - the volume ID + -> IO (Maybe Volume) -- ^ the requested + -- volume, or + -- 'Nothing' if no + -- volume with that + -- ID could be found +volumeMonitorGetVolumeByID volumeMonitor id = + {# call volume_monitor_get_volume_by_id #} (castToVolumeMonitor volumeMonitor) id >>= + maybePeek newVolume + +-- | Returns the 'Volume' corresponding to path, or 'Nothing'. +-- +-- The volume referring to path is found by calling @stat@ on path, +-- and then iterating through the list of volumes that refer to +-- currently mounted local file systems. The first volume in this +-- list maching the path's UNIX device is returned. +-- +-- If the @stat@ on path was not successful, or no volume matches +-- path, 'Nothing' is returned. +volumeMonitorGetVolumeForPath :: VolumeMonitorClass volumeMonitor => + volumeMonitor -- ^ @volumeMonitor@ - the volume monitor + -> FilePath -- ^ the path to + -- find the volume + -- for + -> IO (Maybe Volume) -- ^ the volume the + -- path resides + -- on, or + -- 'Nothing' if + -- the volume + -- could not be + -- determined +volumeMonitorGetVolumeForPath volumeMonitor path = + (withUTFString path $ {# call volume_monitor_get_volume_for_path #} (castToVolumeMonitor volumeMonitor)) >>= + maybePeek newVolume + +onVolumeMonitorDriveConnected, + afterVolumeMonitorDriveConnected, + onVolumeMonitorDriveDisconnected, + afterVolumeMonitorDriveDisconnected, + onVolumeMonitorVolumeMounted, + afterVolumeMonitorVolumeMounted, + onVolumeMonitorVolumePreUnmount, + afterVolumeMonitorVolumePreUnmount, + onVolumeMonitorVolumeUnmounted, + afterVolumeMonitorVolumeUnmounted + :: (VolumeMonitorClass volumeMonitor) => + volumeMonitor -- ^ @volumeMonitor@ - the volume monitor + -> (Volume -> IO ()) -- ^ @handler@ - the signal handling function + -> IO (ConnectId volumeMonitor) -- ^ the identifier for the connection + +onVolumeMonitorDriveConnected = connect_OBJECT__NONE "drive-connected" False +afterVolumeMonitorDriveConnected = connect_OBJECT__NONE "drive-connected" True + +onVolumeMonitorDriveDisconnected = connect_OBJECT__NONE "drive-disconnected" False +afterVolumeMonitorDriveDisconnected = connect_OBJECT__NONE "drive-disconnected" True + +onVolumeMonitorVolumeMounted = connect_OBJECT__NONE "volume-mounted" False +afterVolumeMonitorVolumeMounted = connect_OBJECT__NONE "volume-mounted" True + +onVolumeMonitorVolumePreUnmount = connect_OBJECT__NONE "volume-pre-unmount" False +afterVolumeMonitorVolumePreUnmount = connect_OBJECT__NONE "volume-pre-unmount" True + +onVolumeMonitorVolumeUnmounted = connect_OBJECT__NONE "volume-unmounted" False +afterVolumeMonitorVolumeUnmounted = connect_OBJECT__NONE "volume-unmounted" True diff --git a/System/Gnome/VFS/Xfer.chs b/System/Gnome/VFS/Xfer.chs new file mode 100644 --- /dev/null +++ b/System/Gnome/VFS/Xfer.chs @@ -0,0 +1,280 @@ +{-# LANGUAGE CPP #-} +-- 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 Lesser General Public License +-- as published by the Free Software Foundation, either version 3 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this program. If not, see +-- . +-- +-- GnomeVFS, the C library which this Haskell library depends on, is +-- available under LGPL Version 2. The documentation included with +-- this library is based on the original GnomeVFS documentation, +-- Copyright (c) 2001 Seth Nickell . The +-- documentation is covered by the GNU Free Documentation License, +-- version 1.2. +-- +-- | Maintainer : gtk2hs-devel@lists.sourceforge.net +-- Stability : alpha +-- Portability : portable (depends on GHC) +module System.Gnome.VFS.Xfer ( + +-- * Types + XferProgressInfo(..), + XferOptions ( XferFollowLinks + , XferRecursive + , XferSamefs + , XferDeleteItems + , XferEmptyDirectories + , XferNewUniqueDirectory + , XferRemovesource + , XferUseUniqueNames + , XferLinkItems + , XferFollowLinksRecursive +#if GNOME_VFS_CHECK_VERSION(2,12,0) + , XferTargetDefaultPerms +#endif + ), + XferOverwriteMode ( XferOverwriteModeAbort + , XferOverwriteModeReplace + , XferOverwriteModeSkip ), + XferErrorAction(..), + XferOverwriteAction(..), + XferProgressCallback, + XferErrorCallback, + XferOverwriteCallback, + XferDuplicateCallback, + +-- * Operations + xferURI, + xferURIList, + xferDeleteList + + ) where + +import Control.Monad +import Data.Maybe (fromMaybe) +import System.Glib.FFI +import System.Glib.GList +import System.Glib.UTFString +{#import System.Gnome.VFS.Marshal#} +-- {#import System.Gnome.VFS.Types#} +{#import System.Gnome.VFS.BasicTypes#} + +{# context lib = "gnomevfs" prefix = "gnome_vfs" #} + +{- typedef struct { + - GnomeVFSXferProgressStatus status; + - GnomeVFSResult vfs_status; + - GnomeVFSXferPhase phase; + - gchar *source_name; + - gchar *target_name; + - gulong file_index; + - gulong files_total; + - GnomeVFSFileSize bytes_total; + - GnomeVFSFileSize file_size; + - GnomeVFSFileSize bytes_copied; + - GnomeVFSFileSize total_bytes_copied; + - gchar *duplicate_name; + - int duplicate_count; + - gboolean top_level_item; + - } GnomeVFSXferProgressInfo; + -} + +instance Storable XferProgressInfo where + sizeOf _ = {# sizeof GnomeVFSXferProgressInfo #} + alignment _ = alignment (undefined :: CString) + peek ptr = + do vfsStatus <- liftM cToEnum $ {# get GnomeVFSXferProgressInfo->vfs_status #} ptr + phase <- liftM cToEnum $ {# get GnomeVFSXferProgressInfo->phase #} ptr + sourceName <- {# get GnomeVFSXferProgressInfo->source_name #} ptr >>= maybePeek peekUTFString + targetName <- {# get GnomeVFSXferProgressInfo->target_name #} ptr >>= maybePeek peekUTFString + fileIndex <- liftM fromIntegral $ {# get GnomeVFSXferProgressInfo->file_index #} ptr + filesTotal <- liftM fromIntegral $ {# get GnomeVFSXferProgressInfo->files_total #} ptr + bytesTotal <- liftM fromIntegral $ {# get GnomeVFSXferProgressInfo->bytes_total #} ptr + fileSize <- liftM fromIntegral $ {# get GnomeVFSXferProgressInfo->file_size #} ptr + bytesCopied <- liftM fromIntegral $ {# get GnomeVFSXferProgressInfo->bytes_copied #} ptr + totalBytesCopied <- liftM fromIntegral $ {# get GnomeVFSXferProgressInfo->total_bytes_copied #} ptr + topLevelItem <- liftM toBool $ {# get GnomeVFSXferProgressInfo->top_level_item #} ptr + + return $ XferProgressInfo vfsStatus + phase + sourceName + targetName + fileIndex + filesTotal + bytesTotal + fileSize + bytesCopied + totalBytesCopied + topLevelItem + poke _ = error "XferProgressInfo.poke not implemented" + +type CXferProgressCallback = Ptr () + -> {# type gpointer #} + -> IO CInt +xferProgressCallbackMarshal :: Maybe XferProgressCallback + -> XferErrorCallback + -> XferOverwriteCallback + -> Maybe XferDuplicateCallback + -> IO (FunPtr CXferProgressCallback) +xferProgressCallbackMarshal progressCallback + errorCallback + overwriteCallback + duplicateCallback = + makeXferProgressCallback cCallback + where cCallback :: CXferProgressCallback + cCallback cInfo cUserData = + do status <- liftM cToEnum $ {# get GnomeVFSXferProgressInfo->status #} $ castPtr cInfo + info <- peek $ castPtr cInfo + case status of + XferProgressStatusOk -> + liftM fromBool $ progressCallback' info + XferProgressStatusVfserror -> + liftM cFromEnum $ errorCallback info + XferProgressStatusOverwrite -> + liftM cFromEnum $ overwriteCallback info + XferProgressStatusDuplicate -> + do duplicateCount <- liftM fromIntegral $ {# get GnomeVFSXferProgressInfo->duplicate_count #} cInfo + duplicatePtr <- {# get GnomeVFSXferProgressInfo->duplicate_name #} cInfo + duplicateName <- peekUTFString duplicatePtr + newDuplicateName <- duplicateCallback' info duplicateName duplicateCount + case newDuplicateName of + Just newDuplicateName' -> + do {# call g_free #} $ castPtr duplicatePtr + newUTFString newDuplicateName' >>= + {# set GnomeVFSXferProgressInfo->duplicate_name #} cInfo + return 1 + Nothing -> + return 0 + progressCallback' = + fromMaybe (const $ return True) progressCallback + duplicateCallback' = + fromMaybe (\_ name _ -> return Nothing) duplicateCallback + +foreign import ccall safe "wrapper" + makeXferProgressCallback :: CXferProgressCallback + -> IO (FunPtr CXferProgressCallback) + +type CXfer = {# type GnomeVFSXferOptions #} + -> {# type GnomeVFSXferErrorMode #} + -> {# type GnomeVFSXferOverwriteMode #} + -> FunPtr CXferProgressCallback + -> {# type gpointer #} + -> IO {# type GnomeVFSResult #} +type Xfer = [XferOptions] + -> Maybe XferProgressCallback + -> Maybe XferErrorCallback + -> Either XferOverwriteMode XferOverwriteCallback + -> Maybe XferDuplicateCallback + -> IO () +marshalXfer :: CXfer + -> Xfer +marshalXfer cXfer xferOptions progressCallback errorCallback overwriteOpt duplicateCallback = + voidResultMarshal $ do + cProgressCallback <- xferProgressCallbackMarshal + progressCallback + errorCallback' + overwriteCallback + duplicateCallback + cResult <- cXfer (cFromFlags xferOptions) + (cFromEnum errorMode) + (cFromEnum overwriteMode) + cProgressCallback nullPtr + freeHaskellFunPtr cProgressCallback + return cResult + where + (overwriteMode, overwriteCallback) = + case overwriteOpt of + Left overwriteMode -> + (overwriteMode, + const $ return $ error "marshalXfer: overwrite callback called unexpectedly") + Right overwriteCallback -> + (XferOverwriteModeQuery, + overwriteCallback) + (errorMode, errorCallback') = + case errorCallback of + Just errorCallback' -> + (XferErrorModeQuery, + errorCallback') + Nothing -> + (XferErrorModeAbort, + const $ return $ error "marshalXfer: error callback called unexpectedly") + +-- | Transfer the file located at @sourceURI@ to @targetURI@, using +-- the specified options and callbacks. +xferURI :: URI -- ^ @sourceURI@ - the source URI + -> URI -- ^ @targetURI@ - the target URI + -> [XferOptions] -- ^ @options@ - + -> Maybe XferProgressCallback -- ^ @progressCallback@ - + -> Maybe XferErrorCallback -- ^ @errorCallback@ - + -> Either XferOverwriteMode XferOverwriteCallback -- ^ @overwriteOpt@ - + -> Maybe XferDuplicateCallback -- ^ @duplicateCallback@ - + -> IO () +xferURI sourceURI targetURI = + marshalXfer ({# call xfer_uri #} sourceURI targetURI) + +withURIList :: [URI] + -> (GList -> IO a) + -> IO a +withURIList uriList action = + withMany withURI uriList $ \cURIList -> + toGList cURIList >>= action + +-- | For each pair in @sourceTargetURIList@, transfer the file at the +-- first 'URI' to the second 'URI'. +xferURIList :: [(URI, URI)] -- ^ @sourceTargetURIList@ - + -> [XferOptions] -- ^ @options@ - + -> Maybe XferProgressCallback -- ^ @progressCallback@ - + -> Maybe XferErrorCallback -- ^ @errorCallback@ - + -> Either XferOverwriteMode XferOverwriteCallback -- ^ @overwriteOpt@ - + -> Maybe XferDuplicateCallback -- ^ @duplicateCallback@ - + -> IO () +xferURIList sourceTargetURIList xferOptions progressCallback errorCallback overwriteOpt duplicateCallback = + withURIList sourceURIList $ \cSourceURIList -> + withURIList targetURIList $ \cTargetURIList -> + marshalXfer ({# call xfer_uri_list #} cSourceURIList cTargetURIList) + xferOptions progressCallback + errorCallback overwriteOpt duplicateCallback + where (sourceURIList, targetURIList) = unzip sourceTargetURIList + +-- | Delete the files at the 'URI's in @sourceURIList@. +xferDeleteList :: [URI] -- ^ @sourceURIList@ - + -> [XferOptions] -- ^ @options@ - + -> Maybe XferProgressCallback -- ^ @progressCallback@ - + -> Maybe XferErrorCallback -- ^ @errorCallback@ - + -> IO () +xferDeleteList sourceURIList xferOptions progressCallback errorCallback = + withURIList sourceURIList $ \cSourceURIList -> + do cProgressCallback <- xferProgressCallbackMarshal progressCallback + errorCallback' + (return $ error "xferDeleteList: overwrite callback called unexpectedly") + (return $ error "xferDeleteList: duplicate callback called unexpectedly") + voidResultMarshal $ + {# call xfer_delete_list #} + cSourceURIList + (cFromEnum errorMode) + (cFromFlags xferOptions) + cProgressCallback + nullPtr + where (errorMode, errorCallback') = + case errorCallback of + Just errorCallback' -> + (XferErrorModeQuery, + errorCallback') + Nothing -> + (XferErrorModeAbort, + const $ return XferErrorActionAbort) diff --git a/System/Gnome/VFS/hsfileinfo.c b/System/Gnome/VFS/hsfileinfo.c new file mode 100644 --- /dev/null +++ b/System/Gnome/VFS/hsfileinfo.c @@ -0,0 +1,61 @@ +/* GIMP Toolkit (GTK) Binding for Haskell: binding to libgnomevfs -*-c-*- + * + * 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 Lesser General Public License + * as published by the Free Software Foundation, either version 3 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 + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program. If not, see + * . + * + * GnomeVFS, the C library which this Haskell library depends on, is + * available under LGPL Version 2. The documentation included with + * this library is based on the original GnomeVFS documentation, + * Copyright (c) 2001 Seth Nickell . The + * documentation is covered by the GNU Free Documentation License, + * version 1.2. + */ + +#include "hsfileinfo.h" + +GnomeVFSFileType +_hs_gnome_vfs_file_info_get_type (const GnomeVFSFileInfo *file_info) +{ return file_info->type; } + +GnomeVFSInodeNumber +_hs_gnome_vfs_file_info_get_inode (const GnomeVFSFileInfo *file_info) +{ return file_info->inode; } +GnomeVFSFileSize +_hs_gnome_vfs_file_info_get_size (const GnomeVFSFileInfo *file_info) +{ return file_info->size; } +GnomeVFSFileSize +_hs_gnome_vfs_file_info_get_block_count (const GnomeVFSFileInfo *file_info) +{ return file_info->block_count; } + +void +_hs_gnome_vfs_file_info_set_type (GnomeVFSFileInfo *file_info, + GnomeVFSFileType type) +{ file_info->type = type; } +void +_hs_gnome_vfs_file_info_set_inode (GnomeVFSFileInfo *file_info, + GnomeVFSInodeNumber inode) +{ file_info->inode = inode; } +void +_hs_gnome_vfs_file_info_set_size (GnomeVFSFileInfo *file_info, + GnomeVFSFileSize size) +{ file_info->size = size; } +void +_hs_gnome_vfs_file_info_set_block_count (GnomeVFSFileInfo *file_info, + GnomeVFSFileSize block_count) +{ file_info->block_count = block_count; } diff --git a/System/Gnome/VFS/hsfileinfo.h b/System/Gnome/VFS/hsfileinfo.h new file mode 100644 --- /dev/null +++ b/System/Gnome/VFS/hsfileinfo.h @@ -0,0 +1,57 @@ +/* GIMP Toolkit (GTK) Binding for Haskell: binding to libgnomevfs -*-c-*- + * + * 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 Lesser General Public License + * as published by the Free Software Foundation, either version 3 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 + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program. If not, see + * . + * + * GnomeVFS, the C library which this Haskell library depends on, is + * available under LGPL Version 2. The documentation included with + * this library is based on the original GnomeVFS documentation, + * Copyright (c) 2001 Seth Nickell . The + * documentation is covered by the GNU Free Documentation License, + * version 1.2. + */ + +#include + +/* This is a stub to work around C2HS tripping over "type" as the + field name. */ +GnomeVFSFileType +_hs_gnome_vfs_file_info_get_type (const GnomeVFSFileInfo *file_info); + +/* C2HS doesn't seem to realize GnomeVFSFileSize should be long long */ +GnomeVFSInodeNumber +_hs_gnome_vfs_file_info_get_inode (const GnomeVFSFileInfo *file_info); +GnomeVFSFileSize +_hs_gnome_vfs_file_info_get_size (const GnomeVFSFileInfo *file_info); +GnomeVFSFileSize +_hs_gnome_vfs_file_info_get_block_count (const GnomeVFSFileInfo *file_info); + +void +_hs_gnome_vfs_file_info_set_type (GnomeVFSFileInfo *file_info, + GnomeVFSFileType type); + +void +_hs_gnome_vfs_file_info_set_inode (GnomeVFSFileInfo *file_info, + GnomeVFSInodeNumber inode); +void +_hs_gnome_vfs_file_info_set_size (GnomeVFSFileInfo *file_info, + GnomeVFSFileSize size); +void +_hs_gnome_vfs_file_info_set_block_count (GnomeVFSFileInfo *file_info, + GnomeVFSFileSize block_count); diff --git a/gnomevfs.cabal b/gnomevfs.cabal new file mode 100644 --- /dev/null +++ b/gnomevfs.cabal @@ -0,0 +1,80 @@ +Name: gnomevfs +Version: 0.11.0 +License: GPL +License-file: COPYING +Copyright: (c) 2001-2010 The Gtk2Hs Team +Author: Duncan Coutts +Maintainer: gtk2hs-users@sourceforge.net +Build-Type: Custom +Cabal-Version: >= 1.6 +Stability: stable +homepage: http://www.haskell.org/gtk2hs/ +bug-reports: http://hackage.haskell.org/trac/gtk2hs/ +Synopsis: Binding to the GNOME Virtual File System library. +Description: GNOME VFS is the GNOME virtual file system. It is the foundation of the + Nautilus file manager. It provides a modular architecture and ships with + several modules that implement support for local files, http, ftp and others. + It provides an URI-based API, a backend supporting asynchronous file + operations, a MIME type manipulation library and other features. + +Category: System +Tested-With: GHC == 6.12.1 +Extra-Source-Files: hsgnomevfs-2.14.h + System/Gnome/VFS/hsfileinfo.h + Gtk2HsSetup.hs + marshal.list + +x-Types-File: System/Gnome/VFS/Types.chs +x-Types-Tag: gnomevfs +x-Types-ModName: System.Gnome.VFS.Types +x-Types-Forward: Graphics.UI.GtkInternals +x-Types-Destructor: objectUnrefFromMainloop + +Source-Repository head + type: darcs + location: http://code.haskell.org/gtk2hs/ + subdir: gnomevfs + +Library + build-depends: base >= 4 && < 5, array, containers, haskell98, mtl, + glib >= 0.11 && < 0.12, + gtk >= 0.11 && < 0.12 + + build-tools: gtk2hsC2hs, gtk2hsHookGenerator, gtk2hsTypeGen + + exposed-modules: + System.Gnome.VFS + System.Gnome.VFS.Cancellation + System.Gnome.VFS.Directory + System.Gnome.VFS.Drive + System.Gnome.VFS.Error + System.Gnome.VFS.FileInfo + System.Gnome.VFS.Init + System.Gnome.VFS.MIME + System.Gnome.VFS.Monitor + System.Gnome.VFS.Ops + System.Gnome.VFS.URI + System.Gnome.VFS.Util + System.Gnome.VFS.Volume + System.Gnome.VFS.VolumeMonitor + System.Gnome.VFS.Xfer + + other-modules: + System.Gnome.VFS.Types + System.Gnome.VFS.Signals + System.Gnome.VFS.BasicTypes + System.Gnome.VFS.Marshal + System.Gnome.VFS.Constants + + extensions: ForeignFunctionInterface + c-sources: System/Gnome/VFS/hsfileinfo.c + + x-Signals-File: System/Gnome/VFS/Signals.chs + x-Signals-Modname: System.Gnome.VFS.Signals + x-Signals-Types: marshal.list + x-Signals-Import: Graphics.UI.GtkInternals + + x-c2hs-Header: hsgnomevfs-2.14.h + include-dirs: System/Gnome/VFS/ + cpp-options: -DHAVE_NEW_CONTROL_EXCEPTION + pkgconfig-depends: gnome-vfs-2.0 >= 2.0.0, gnome-vfs-module-2.0 >= 2.0.0 diff --git a/hsgnomevfs-2.14.h b/hsgnomevfs-2.14.h new file mode 100644 --- /dev/null +++ b/hsgnomevfs-2.14.h @@ -0,0 +1,3 @@ +#include +#include +#include diff --git a/marshal.list b/marshal.list new file mode 100644 --- /dev/null +++ b/marshal.list @@ -0,0 +1,45 @@ +# see glib-genmarshal(1) for a detailed description of the file format, +# possible parameter types are: +# VOID indicates no return type, or no extra +# parameters. if VOID is used as the parameter +# list, no additional parameters may be present. +# BOOLEAN for boolean types (gboolean) +# CHAR for signed char types (gchar) +# UCHAR for unsigned char types (guchar) +# INT for signed integer types (gint) +# UINT for unsigned integer types (guint) +# LONG for signed long integer types (glong) +# ULONG for unsigned long integer types (gulong) +# ENUM for enumeration types (gint) +# FLAGS for flag enumeration types (guint) +# FLOAT for single-precision float types (gfloat) +# DOUBLE for double-precision float types (gdouble) +# STRING for string types (gchar*) +# BOXED for boxed (anonymous but reference counted) types (GBoxed*) +# POINTER for anonymous pointer types (gpointer) +# NONE deprecated alias for VOID +# BOOL deprecated alias for BOOLEAN + +# +# One discrepancy from Gtk+ is that for signals that may pass NULL for an object +# reference, the Haskell signal should be passed a 'Maybe GObject'. +# We therefore have two variants that are marshalled as a maybe type: +# +# OBJECT for GObject or derived types (GObject*) +# MOBJECT for GObject or derived types (GObject*) that may be NULL + +# Furthermore, some objects needs to be destroyed synchronously from the main loop of +# Gtk rather than during GC. These objects need to be marshalled using TOBJECT (for thread-safe +# object). It doesn't hurt to use TOBJECT for an object that doesn't need it, except for the +# some performance. As a rule of thumb, use TOBJECT for all libraries that build on package +# 'gtk' and use OBJECT for all packages that only need packages 'glib', 'pango', 'cairo', +# 'gio'. Again both variants exist. Note that the same names will be generated for OBJECT and +# TOBJECT, so you have to remove the OBJECT handler if you need both. +# +# TOBJECT for GObject or derived types (GObject*) +# MTOBJECT for GObject or derived types (GObject*) that may be NULL + +# If you add a new signal type, please check that it actually works! +# If it is a Boxed type check that the reference counting is right. + +NONE:TOBJECT