Commit 9b43c94c authored by Bas Lijnse's avatar Bas Lijnse

Added MySQL bindings for windows and added 'lpad' and 'rpad' padding functions to the Text library

git-svn-id: https://svn.cs.ru.nl/repos/clean-platform/trunk@49 2afc29ad-3112-4e41-907a-9359c7e6e986
parent d4fb3287
......@@ -18,6 +18,8 @@ Environments
Path: {Application}\Platform\src\libraries\OS-Independent\Text\Encodings
Path: {Application}\Platform\src\libraries\OS-Windows\Network
Path: {Application}\Platform\src\libraries\OS-Windows\System
Path: {Application}\Platform\src\libraries\OS-Windows\Database
Path: {Application}\Platform\src\libraries\OS-Windows\Database\SQL
EnvironmentCompiler: Tools\Clean System\CleanCompiler.exe
EnvironmentCodeGen: Tools\Clean System\CodeGenerator.exe
EnvironmentLinker: Tools\Clean System\StaticLinker.exe
......
module SQLDbDemo
import StdEnv
import SQL
import MySQL
import Text
Start :: !*World -> (!String,!*World)
Start world
# (cursor, connection, context, world) = dbInit world
//# (err,cursor) = execute "INSERT INTO project VALUES(NULL,?,NULL)" [SQLVVarchar "testje"] cursor
# (err,cursor) = execute "SELECT * FROM project" [] cursor
| isJust err = (toString (fromJust err),world)
//# (err,id,cursor) = insertId cursor
# (err,mbRow,cursor) = fetchOne cursor
| isJust err = (toString (fromJust err),world)
# world = dbEnd cursor connection context world
= (foldr (+++) " " (map toString (fromJust mbRow)),world)
where
dbInit :: !*World -> (!*MySQLCursor, !*MySQLConnection, !*MySQLContext, !*World)
dbInit world
# (err,mbContext,world) = openContext world
| isJust err = abort (toString (fromJust err))
# (err,mbConn,context) = openConnection "localhost" "root" "test" "pmdemo" (fromJust mbContext)
| isJust err = abort (toString (fromJust err))
# (err,mbCursor,connection) = openCursor (fromJust mbConn)
| isJust err = abort (toString (fromJust err))
= (fromJust mbCursor,connection, context, world)
dbEnd :: !*MySQLCursor !*MySQLConnection !*MySQLContext !*World -> *World
dbEnd cursor connection context world
# (err,connection) = closeCursor cursor connection
# (err,context) = closeConnection connection context
# (err,world) = closeContext context world
= world
\ No newline at end of file
definition module SQL
// *********************************************************************************************************************
// Clean Relational Database (SQL) API. v 0.2
// This module defines a common API for working with relational databases.
// *********************************************************************************************************************
import StdString, Maybe
// *********************************************************************************************************************
// Basic types
// *********************************************************************************************************************
// SQL Statements and queries are just strings
:: SQLStatement :== String
// This type represents the possible values that elements of a row in a
// result set can have. The constructors map directly to the constructors of
// the SQLType type.
:: SQLValue = SQLVChar !String
| SQLVVarchar !String
| SQLVText !String
| SQLVInteger !Int
| SQLVReal !Real
| SQLVFloat !Real
| SQLVDouble !Real
| SQLVDate !SQLDate
| SQLVTime !SQLTime
| SQLVTimestamp !Int
| SQLVDatetime !SQLDate !SQLTime
| SQLVEnum !String
| SQLVNull
| SQLVBlob !String
| SQLVUnknown !String
// Date and time structures
:: SQLDate =
{ year :: !Int
, month :: !Int
, day :: !Int
}
:: SQLTime =
{ hour :: !Int
, minute :: !Int
, second :: !Int
}
// A row is just a list of values
:: SQLRow :== [SQLValue]
// *********************************************************************************************************************
// Errors
// *********************************************************************************************************************
// Warning: Non fatal errors, you can still continue
// InterfaceError: Error related to the interface, not the database itself
// DatabaseError: Error related to the database that can not be classified
// as Operational error or Internal error
// DataError: Error due to problems with the data
// OperationalError: Error due to operational problems with the database.
// E.g. disconnects, memory full etc.
// IntegrityError: Errors related to data integrity, e.g. key constraint
// violations
// InternalError: Errors related to internal problems in the database
// library
// ProgrammingError: Errors of the end user, e.g. syntax errors in SQL
// statements
// NotSupportedError: An operation is not supported by the database library
:: SQLError = SQLWarning Int String
| SQLInterfaceError Int String
| SQLDatabaseError Int String
| SQLDataError Int String
| SQLOperationalError Int String
| SQLIntegrityError Int String
| SQLInternalError Int String
| SQLProgrammingError Int String
| SQLNotSupportedError
// *********************************************************************************************************************
// Database Interaction API
// *********************************************************************************************************************
class SQLEnvironment env ctx
where
openContext :: !*env -> (!(Maybe SQLError), !(Maybe *ctx), !*env)
closeContext :: !*ctx !*env -> (!(Maybe SQLError), !*env)
class SQLContext ctx con
where
openConnection :: !String !String !String !String !*ctx -> (!(Maybe SQLError), !(Maybe *con), !*ctx)
closeConnection :: !*con !*ctx -> (!(Maybe SQLError), !*ctx)
class SQLConnection con cur
where
openCursor :: !*con -> (!(Maybe SQLError), !(Maybe *cur), !*con)
closeCursor :: !*cur !*con -> (!(Maybe SQLError), !*con)
class SQLCursor cur
where
execute :: !SQLStatement ![SQLValue] !*cur -> (!(Maybe SQLError), !*cur)
executeMany :: !SQLStatement ![[SQLValue]] !*cur -> (!(Maybe SQLError), !*cur)
numRows :: !*cur -> (!(Maybe SQLError), !Int, !*cur)
numFields :: !*cur -> (!(Maybe SQLError), !Int, !*cur)
insertId :: !*cur -> (!(Maybe SQLError), !Int, !*cur)
fetchOne :: !*cur -> (!(Maybe SQLError), !(Maybe SQLRow), !*cur)
fetchMany :: !Int !*cur -> (!(Maybe SQLError), ![SQLRow], !*cur)
fetchAll :: !*cur -> (!(Maybe SQLError), ![SQLRow], !*cur)
commit :: !*cur -> (!(Maybe SQLError), !*cur)
rollback :: !*cur -> (!(Maybe SQLError), !*cur)
// *********************************************************************************************************************
// Common class instances
// *********************************************************************************************************************
instance toString SQLValue, SQLDate, SQLTime, SQLError
instance == SQLValue, SQLDate, SQLTime
implementation module SQL
import StdString, StdList, StdBool, Maybe, Text
//Utility functions
instance toString SQLValue
where
toString (SQLVChar s) = "SQLVChar " +++ s
toString (SQLVVarchar s) = "SQLVVarchar " +++ s
toString (SQLVText s) = "SQLVText " +++ s
toString (SQLVInteger i) = "SQLVInteger " +++ (toString i)
toString (SQLVReal r) = "SQLVReal " +++ (toString r)
toString (SQLVFloat f) = "SQLVFloat " +++ (toString f)
toString (SQLVDouble d) = "SQLVDouble " +++ (toString d)
toString (SQLVDate d) = "SQLVDate " +++ (toString d)
toString (SQLVTime t) = "SQLVTime " +++ (toString t)
toString (SQLVTimestamp i) = "SQLVTimestamp " +++ (toString i)
toString (SQLVDatetime d t) = "SQLVDatetime " +++ (toString d) +++ " " +++ (toString t)
toString (SQLVEnum s) = "SQLVEnum " +++ s
toString (SQLVNull) = "SQLVNull"
toString (SQLVBlob s) = "SQLVBlob " +++ s
toString (SQLVUnknown s) = "SQLVUnknown " +++ s
instance toString SQLDate
where
toString {SQLDate|year,month,day} = lpad (toString year) 4 '0' +++ "-" +++ lpad (toString month) 2 '0' +++ "-" +++ lpad (toString day) 2 '0'
instance toString SQLTime
where
toString {SQLTime|hour,minute,second} = lpad (toString hour) 2 '0' +++ ":" +++ lpad (toString minute) 2 '0' +++ ":" +++ lpad (toString second) 2 '0'
instance toString SQLError
where
toString (SQLWarning errno errmsg) = "SQLWarning " +++ toString errno +++ ": " +++ errmsg
toString (SQLInterfaceError errno errmsg) = "SQLInterfaceError " +++ toString errno +++ ": " +++ errmsg
toString (SQLDatabaseError errno errmsg) = "SQLDatabaseError " +++ toString errno +++ ": " +++ errmsg
toString (SQLDataError errno errmsg) = "SQLDataError " +++ toString errno +++ ": " +++ errmsg
toString (SQLOperationalError errno errmsg) = "SQLOperationalError " +++ toString errno +++ ": " +++ errmsg
toString (SQLIntegrityError errno errmsg) = "SQLIntegrityError " +++ toString errno +++ ": " +++ errmsg
toString (SQLInternalError errno errmsg) = "SQLInternalError " +++ toString errno +++ ": " +++ errmsg
toString (SQLProgrammingError errno errmsg) = "SQLProgrammingError " +++ toString errno +++ ": " +++ errmsg
toString (SQLNotSupportedError) = "SQLNotSupportedError"
instance == SQLValue
where
(==) (SQLVChar x) (SQLVChar y) = x == y
(==) (SQLVVarchar x) (SQLVVarchar y) = x == y
(==) (SQLVText x) (SQLVText y) = x == y
(==) (SQLVInteger x) (SQLVInteger y) = x == y
(==) (SQLVReal x) (SQLVReal y) = x == y
(==) (SQLVFloat x) (SQLVFloat y) = x == y
(==) (SQLVDouble x) (SQLVDouble y) = x == y
(==) (SQLVDate x) (SQLVDate y) = x == y
(==) (SQLVTime x) (SQLVTime y) = x == y
(==) (SQLVTimestamp x) (SQLVTimestamp y) = x == y
(==) (SQLVDatetime xd xt) (SQLVDatetime yd yt) = xd == yd && xt == yt
(==) (SQLVEnum x) (SQLVEnum y) = x == y
(==) (SQLVNull) (SQLVNull) = True
(==) (SQLVBlob x) (SQLVBlob y) = x == y
(==) (SQLVUnknown x) (SQLVUnknown y) = x == y
(==) _ _ = False
instance == SQLDate
where
(==) {SQLDate|year=xyear,month=xmonth,day=xday} {SQLDate|year=yyear,month=ymonth,day=yday}
= xyear == yyear && xmonth == ymonth && xday == yday
instance == SQLTime
where
(==) {SQLTime|hour=xhour,minute=xminute,second=xsecond} {SQLTime|hour=yhour,minute=yminute,second=ysecond}
= xhour == yhour && xminute == yminute && xsecond == ysecond
\ No newline at end of file
......@@ -98,6 +98,16 @@ class Text s
*/
rtrim :: !s -> s
/**
* Pads a string to a fixed length by adding characters to the beginning of a string.
*/
lpad :: !s !Int !Char -> s
/**
* Pads a string to a fixed length by adding characters to the end of a string.
*/
rpad :: !s !Int !Char -> s
/**
* Converts all characters in a string to lower case.
*/
......
......@@ -68,6 +68,14 @@ instance Text String
| isSpace s.[size s - 1] = if (size s == 1) "" (rtrim (s % (0, size s - 2)))
= s
lpad :: !String !Int !Char -> String
lpad s w c
= let boundary = w - size s in {if (i < boundary) c s.[i - boundary] \\ i <- [0.. w - 1]}
rpad :: !String !Int !Char -> String
rpad s w c
= let boundary = size s in {if (i < boundary) s.[i] c \\ i <- [0.. w - 1]}
toLowerCase :: !String -> String
toLowerCase s = {toLower c \\ c <-: s}
......
libmysql.dll
mysql_affected_rows@4
mysql_close@4
mysql_errno@4
mysql_error@4
mysql_fetch_fields@4
mysql_fetch_lengths@4
mysql_fetch_row@4
mysql_free_result@4
mysql_init@4
mysql_insert_id@4
mysql_num_fields@4
mysql_num_rows@4
mysql_real_connect@32
mysql_real_escape_string@16
mysql_real_query@12
mysql_store_result@4
\ No newline at end of file
definition module MySQL
//This module defines implements the interface for relatational databases
//of SQL.dcl for the MySQL database engine
import SQL
import Maybe, StdString
:: MySQLContext
:: MySQLConnection
:: MySQLCursor
instance SQLEnvironment World MySQLContext
instance SQLContext MySQLContext MySQLConnection
instance SQLConnection MySQLConnection MySQLCursor
instance SQLCursor MySQLCursor
This diff is collapsed.
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment