Bryan O'Sullivan avatar Bryan O'Sullivan committed 835762a Merge

Merge

Comments (0)

Files changed (2)

Database/HDBC/MySQL.hs

               'mysqlPassword' = \"tiger\"
             }
     'quickQuery'' conn \"SELECT 1 + 1\" []
-  forM_ rows $ \row -> putStrLn $ show row
+  forM_ rows $ \\row -> putStrLn $ show row
 @
 
 There are some important caveats to note about this driver.

Database/HDBC/MySQL/Connection.hsc

     , mysqlPort       :: Int
       -- | The absolute path of the server's Unix socket; e.g., @\"\/var\/lib\/mysql.sock\"@
     , mysqlUnixSocket :: String
+      -- | The group name in my.cnf from which it reads options; e.g., @\"test\"@
+    , mysqlGroup      :: Maybe String
     }
 
 {- | Typical connection information, meant to be overridden partially,
 
 -}
 defaultMySQLConnectInfo :: MySQLConnectInfo
-defaultMySQLConnectInfo = MySQLConnectInfo "127.0.0.1" "root" "" "test" 3306 ""
+defaultMySQLConnectInfo = MySQLConnectInfo "127.0.0.1" "root" "" "test" 3306 "" Nothing
 
 data Connection = Connection
     { disconnect :: IO ()
 connectMySQL info = do
   mysql_ <- mysql_init nullPtr
   when (mysql_ == nullPtr) (error "mysql_init failed")
+  case mysqlGroup info of
+    Just group -> withCString group $ \group_ -> do
+                      _ <- mysql_options mysql_ #{const MYSQL_READ_DEFAULT_GROUP} (castPtr group_)
+                      return ()
+    Nothing -> return ()
   withCString (mysqlHost info) $ \host_ ->
       withCString (mysqlUser info) $ \user_ ->
           withCString (mysqlPassword info) $ \passwd_ ->
           rv <- mysql_stmt_fetch stmt_
           case rv of
             0                             -> row
-            #{const MYSQL_DATA_TRUNCATED} -> row
+            #{const MYSQL_DATA_TRUNCATED} -> liftM Just $ mapM (uncurry $ fill stmt_) $ zip [0..] results
             #{const MYSQL_NO_DATA}        -> finalizeForeignPtr stmt__ >> return Nothing
             _                             -> statementError stmt_
-    where row = mapM cellValue results >>= \cells -> return $ Just cells
+    where row = liftM Just $ mapM cellValue results
+          fill stmt_ column bind = do
+            err <- peek $ bindError bind
+            if err == 1 then do len <- peek $ bindLength bind
+                                bracket (mallocBytes $ fromIntegral len) free $ \buffer_ ->
+                                    do let tempBind = bind { bindBuffer = buffer_, bindBufferLength = len }
+                                       rv <- with tempBind $ \bind_ -> mysql_stmt_fetch_column stmt_ bind_ column 0
+                                       when (rv /= 0) (statementError stmt_)
+                                       cellValue tempBind
+                        else cellValue bind
 
 -- Produces a single SqlValue cell value given the binding, handling
 -- nulls appropriately.
  :: Ptr MYSQL
  -> IO (Ptr MYSQL)
 
+foreign import ccall unsafe mysql_options
+ :: Ptr MYSQL
+ -> CInt
+ -> Ptr ()
+ -> IO CInt
+
 foreign import ccall unsafe mysql_real_connect
  :: Ptr MYSQL -- the context
  -> CString   -- hostname
 foreign import ccall unsafe mysql_stmt_fetch
     :: Ptr MYSQL_STMT -> IO CInt
 
+foreign import ccall unsafe mysql_stmt_fetch_column
+    :: Ptr MYSQL_STMT -> Ptr MYSQL_BIND -> CUInt -> CULong -> IO CInt
+
 foreign import ccall unsafe mysql_stmt_close
     :: Ptr MYSQL_STMT -> IO ()
 
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.