REBOL [
    Title: "MySQL database interfacing logic."
    Date: 18-May-2001/9:24:31+2:00
    Version: 1.0.0
    File: %mysql_all.r
    Author: "Maarten Koopmans, Ernie van der Meer"
    Purpose: {Interface to the mysql libs, needs /Pro or /Command}
    Email: m.koopmans2@chello.nl
    dependant: "Depends on contract.r"
    Limititations: "NO error handling yet"
    library: [
        level: none 
        platform: none 
        type: none 
        domain: 'DB 
        tested-under: none 
        support: none 
        license: none 
        see-also: none
    ]
]

; Make sure we know about contract and such.
system/error/user: make system/error/user [ pre-error: [ "The precondition " :arg1 " was not met" ]  ]
system/error/user: make system/error/user [ post-error: [ "The postcondition " :arg1 " was not met" ]  ]


block-all: func [ { Block variant on all.  Evaluates al netsed blocks as conditions.} a [any-block!]][

    ;Are we @ the tail? Then we have evaluated all the conditions succesfully. Return true.
    either tail? a
    ; We are at the end of the conditions, return true
    [ return true]
    [
      ; Is the block empty or does it contain none
      either any [ empty? first a none? first first a]
      [
        ;yes, skip and do the next condition
        block-all next a
      ]
      [
        ;Continue... we have a valid condition
        ;If the first condition is true, recursively call block-all on the next
        either do first a
        [ block-all next a]
        [return false]
      ];either any
    ]
]

find-false: func [ {Finds the first false block in a block of blocks and return at the start of it.}  a [any-block!] ]
                 [
                   ;Initialize. Skip all empty and none! conditions
                   ;until [ either any [ empty? first a none? first first a]  [a: next a ] [true ] ]
                   while [all [(not tail? a) (do first a)] ]
                   [
                     ;go to the next element and skip empty ones and ones of type none!
                     until [ either any [ empty? first a none? first first a]  [a: next a false] [a: next a true ] ]
                   ]
                   return  copy a
                 ]

contract: func [ {Contracts are functions that support pre and post conditions, aka design by contract.
                                    Note that your code should return a value (at least none) for this to work.}
                 args [any-block!] {Function arguments.}
                 conditions [any-block!] { conditions in the format: [ pre [ [cond1] [cond2]] post [[cond3] ..]}
                 locals [any-block!] {Local variables to the function.}
                 body [any-block!] {The body of the function, should ALWAYS return a value (at least none).}
                 /local pre-cond post-cond pre-code post-code func-args func-body
                                    cond-block do-func inner-func do-body
               ]
               [
                 pre-code: copy []
                 post-code: copy []

                 ;Find the pre conditions
                 pre-cond: select conditions 'pre
                 if (not none? pre-cond)
                 [
                    ;Pre-code is the code for the precondition.
                    pre-code: copy compose/deep [ if not block-all compose/deep [(pre-cond)]]
                    ;Append some code. We need to split the compose because we use a compose again in the resulting code :)
                    append cond-block: copy compose/deep [ cond: mold first find-false compose/deep [(pre-cond)]] [ make error! compose [ user pre-error (cond)]]
                    ;And append the cond-block to pre-code. Now we have our pre-code ready.
                    append/only pre-code cond-block
                 ]

                 post-cond: select conditions 'post
                 ;Find the pre conditions
                 if (not none? post-cond)
                 [
                    ;Pre-code is the code for the precondition.
                    post-code: copy compose/deep [ if not block-all compose/deep [(post-cond)]]
                    ;Append and compose some code. We need to split the compose because we use a compose again in the resulting code :)
                    append cond-block: copy compose/deep [ cond: mold first find-false compose/deep [(post-cond)]] [ make error! compose [ user post-error (cond)]]
                    ;And append the cond-block to pre-code. Now we have our pre-code ready.
                    append/only post-code cond-block
                 ]

                                 ;Append the local variables to the argument block
                 append func-args: copy args /local
                                 append func-args [ __return __ret_err]
                                 append func-args locals

                                 ;if the body is empty, make sure it returns none
                                 if body = []
                                 [
                                    body: copy [ none ]
                                 ]

                                 ;We evaluate the body as an anonymous function with access to all or locals
                                 do-body:  copy compose/deep [ __innerfunc: func [] [(:body)]]


                 ; Change the function body to include the conditions
                                 func-body: copy []
                                 ; we at least return none
                                 insert func-body copy [ __return: none ]
                                 append func-body copy pre-code
                                 append func-body do-body
                                 append func-body copy [ __return: __innerfunc ]
                 append func-body copy post-code
                                 append func-body copy [ __return ]

                 ;Create and return the function
                 return func func-args func-body

               ]

; Get the method signatures for MySQL
;Change to whatever is the path to your MySQL client lib
mysql-lib: load/library %libmysql.dll


mysql-error-map:
[ ER_HASHCHK 1000
  ER_NISAMCHK 1001
  ER_NO 1002
  ER_YES 1003
  ER_CANT_CREATE_FILE 1004
  ER_CANT_CREATE_TABLE 1005
  ER_CANT_CREATE_DB 1006
  ER_DB_CREATE_EXISTS 1007
  ER_DB_DROP_EXISTS 1008
  ER_DB_DROP_DELETE 1009
  ER_DB_DROP_RMDIR 1010
  ER_CANT_DELETE_FILE 1011
  ER_CANT_FIND_SYSTEM_REC 1012
  ER_CANT_GET_STAT 1013
  ER_CANT_GET_WD 1014
  ER_CANT_LOCK 1015
  ER_CANT_OPEN_FILE 1016
  ER_FILE_NOT_FOUND 1017
  ER_CANT_READ_DIR 1018
  ER_CANT_SET_WD 1019
  ER_CHECKREAD 1020
  ER_DISK_FULL 1021
  ER_DUP_KEY 1022
  ER_ERROR_ON_CLOSE 1023
  ER_ERROR_ON_READ 1024
  ER_ERROR_ON_RENAME 1025
  ER_ERROR_ON_WRITE 1026
  ER_FILE_USED 1027
  ER_FILSORT_ABORT 1028
  ER_FORM_NOT_FOUND 1029
  ER_GET_ERRNO 1030
  ER_ILLEGAL_HA 1031
  ER_KEY_NOT_FOUND 1032
  ER_NOT_FORM_FILE 1033
  ER_NOT_KEYFILE 1034
  ER_OLD_KEYFILE 1035
  ER_OPEN_AS_READONLY 1036
  ER_OUTOFMEMORY 1037
  ER_OUT_OF_SORTMEMORY 1038
  ER_UNEXPECTED_EOF 1039
  ER_CON_COUNT_ERROR 1040
  ER_OUT_OF_RESOURCES 1041
  ER_BAD_HOST_ERROR 1042
  ER_HANDSHAKE_ERROR 1043
  ER_DBACCESS_DENIED_ERROR 1044
  ER_ACCESS_DENIED_ERROR 1045
  ER_NO_DB_ERROR 1046
  ER_UNKNOWN_COM_ERROR 1047
  ER_BAD_NULL_ERROR 1048
  ER_BAD_DB_ERROR 1049
  ER_TABLE_EXISTS_ERROR 1050
  ER_BAD_TABLE_ERROR 1051
  ER_NON_UNIQ_ERROR 1052
  ER_SERVER_SHUTDOWN 1053
  ER_BAD_FIELD_ERROR 1054
  ER_WRONG_FIELD_WITH_GROUP 1055
  ER_WRONG_GROUP_FIELD 1056
  ER_WRONG_SUM_SELECT 1057
  ER_WRONG_VALUE_COUNT 1058
  ER_TOO_LONG_IDENT 1059
  ER_DUP_FIELDNAME 1060
  ER_DUP_KEYNAME 1061
  ER_DUP_ENTRY 1062
  ER_WRONG_FIELD_SPEC 1063
  ER_PARSE_ERROR 1064
  ER_EMPTY_QUERY 1065
  ER_NONUNIQ_TABLE 1066
  ER_INVALID_DEFAULT 1067
  ER_MULTIPLE_PRI_KEY 1068
  ER_TOO_MANY_KEYS 1069
  ER_TOO_MANY_KEY_PARTS 1070
  ER_TOO_LONG_KEY 1071
  ER_KEY_COLUMN_DOES_NOT_EXITS 1072
  ER_BLOB_USED_AS_KEY 1073
  ER_TOO_BIG_FIELDLENGTH 1074
  ER_WRONG_AUTO_KEY 1075
  ER_READY 1076
  ER_NORMAL_SHUTDOWN 1077
  ER_GOT_SIGNAL 1078
  ER_SHUTDOWN_COMPLETE 1079
  ER_FORCING_CLOSE 1080
  ER_IPSOCK_ERROR 1081
  ER_NO_SUCH_INDEX 1082
  ER_WRONG_FIELD_TERMINATORS 1083
  ER_BLOBS_AND_NO_TERMINATED 1084
  ER_TEXTFILE_NOT_READABLE 1085
  ER_FILE_EXISTS_ERROR 1086
  ER_LOAD_INFO 1087
  ER_ALTER_INFO 1088
  ER_WRONG_SUB_KEY 1089
  ER_CANT_REMOVE_ALL_FIELDS 1090
  ER_CANT_DROP_FIELD_OR_KEY 1091
  ER_INSERT_INFO 1092
  ER_INSERT_TABLE_USED 1093
  ER_NO_SUCH_THREAD 1094
  ER_KILL_DENIED_ERROR 1095
  ER_NO_TABLES_USED 1096
  ER_TOO_BIG_SET 1097
  ER_NO_UNIQUE_LOGFILE 1098
  ER_TABLE_NOT_LOCKED_FOR_WRITE 1099
  ER_TABLE_NOT_LOCKED 1100
  ER_BLOB_CANT_HAVE_DEFAULT 1101
  ER_WRONG_DB_NAME 1102
  ER_WRONG_TABLE_NAME 1103
  ER_TOO_BIG_SELECT 1104
  ER_UNKNOWN_ERROR 1105
  ER_UNKNOWN_PROCEDURE 1106
  ER_WRONG_PARAMCOUNT_TO_PROCEDURE 1107
  ER_WRONG_PARAMETERS_TO_PROCEDURE 1108
  ER_UNKNOWN_TABLE 1109
  ER_FIELD_SPECIFIED_TWICE 1110
  ER_INVALID_GROUP_FUNC_USE 1111
  ER_UNSUPPORTED_EXTENSION 1112
  ER_TABLE_MUST_HAVE_COLUMNS 1113
  ER_RECORD_FILE_FULL 1114
  ER_UNKNOWN_CHARACTER_SET 1115
  ER_TOO_MANY_TABLES 1116
  ER_TOO_MANY_FIELDS 1117
  ER_TOO_BIG_ROWSIZE 1118
  ER_STACK_OVERRUN 1119
  ER_WRONG_OUTER_JOIN 1120
  ER_NULL_COLUMN_IN_INDEX 1121
  ER_CANT_FIND_UDF 1122
  ER_CANT_INITIALIZE_UDF 1123
  ER_UDF_NO_PATHS 1124
  ER_UDF_EXISTS 1125
  ER_CANT_OPEN_LIBRARY 1126
  ER_CANT_FIND_DL_ENTRY 1127
  ER_FUNCTION_NOT_DEFINED 1128
  ER_HOST_IS_BLOCKED 1129
  ER_HOST_NOT_PRIVILEGED 1130
  ER_PASSWORD_ANONYMOUS_USER 1131
  ER_PASSWORD_NOT_ALLOWED 1132
  ER_PASSWORD_NO_MATCH 1133
  ER_UPDATE_INFO 1134
  ER_CANT_CREATE_THREAD 1135
  ER_WRONG_VALUE_COUNT_ON_ROW 1136
  ER_CANT_REOPEN_TABLE 1137
  ER_INVALID_USE_OF_NULL 1138
  ER_REGEXP_ERROR 1139
  ER_MIX_OF_GROUP_FUNC_AND_FIELDS 1140
  ER_NONEXISTING_GRANT 1141
  ER_TABLEACCESS_DENIED_ERROR 1142
  ER_COLUMNACCESS_DENIED_ERROR 1143
  ER_ILLEGAL_GRANT_FOR_TABLE 1144
  ER_GRANT_WRONG_HOST_OR_USER 1145
  ER_NO_SUCH_TABLE 1146
  ER_NONEXISTING_TABLE_GRANT 1147
  ER_NOT_ALLOWED_COMMAND 1148
  ER_SYNTAX_ERROR 1149
  ER_DELAYED_CANT_CHANGE_LOCK 1150
  ER_TOO_MANY_DELAYED_THREADS 1151
  ER_ABORTING_CONNECTION 1152
  ER_NET_PACKET_TOO_LARGE 1153
  ER_NET_READ_ERROR_FROM_PIPE 1154
  ER_NET_FCNTL_ERROR 1155
  ER_NET_PACKETS_OUT_OF_ORDER 1156
  ER_NET_UNCOMPRESS_ERROR 1157
  ER_NET_READ_ERROR 1158
  ER_NET_READ_INTERRUPTED 1159
  ER_NET_ERROR_ON_WRITE 1160
  ER_NET_WRITE_INTERRUPTED 1161
  ER_TOO_LONG_STRING 1162
  ER_TABLE_CANT_HANDLE_BLOB 1163
  ER_TABLE_CANT_HANDLE_AUTO_INCREMENT 1164
  ER_DELAYED_INSERT_TABLE_LOCKED 1165
  ER_WRONG_COLUMN_NAME 1166
  ER_WRONG_KEY_COLUMN 1167
  ER_WRONG_MRG_TABLE 1168
  ER_DUP_UNIQUE 1169
  ER_BLOB_KEY_WITHOUT_LENGTH 1170
  ER_PRIMARY_CANT_HAVE_NULL 1171
  ER_TOO_MANY_ROWS 1172
  ER_REQUIRES_PRIMARY_KEY 1173
  ER_NO_RAID_COMPILED 1174
  ER_UPDATE_WITHOUT_KEY_IN_SAFE_MODE 1175
  ER_KEY_DOES_NOT_EXITS 1176
  ER_CHECK_NO_SUCH_TABLE 1177
  ER_CHECK_NOT_IMPLEMENTED 1178
  ER_CANT_DO_THIS_DURING_AN_TRANSACTION 1179
  ER_ERROR_DURING_COMMIT 1180
  ER_ERROR_DURING_ROLLBACK 1181
  ER_ERROR_DURING_FLUSH_LOGS 1182
  ER_ERROR_DURING_CHECKPOINT 1183
  ER_NEW_ABORTING_CONNECTION 1184
  ER_DUMP_NOT_IMPLEMENTED    1185
  ER_FLUSH_MASTER_BINLOG_CLOSED 1186
  ER_INDEX_REBUILD  1187
  ER_MASTER 1188
  ER_MASTER_NET_READ 1189
  ER_MASTER_NET_WRITE 1190
  ER_FT_MATCHING_KEY_NOT_FOUND 1191
  ER_LOCK_OR_ACTIVE_TRANSACTION 1192
  ER_ERROR_MESSAGES 193
];mysql-error-map

mysql-init: make routine!
[
  [save]
  in [integer!]
  return: [integer!]
] mysql-lib "mysql_init"

mysql-connect: make routine!
[
  [save]
  mysql       [integer!]
  host        [string!]
  user        [string!]
  passwd      [string!]
  db          [string!]
  port        [integer!]
  socket      [integer!]
  clientflag  [integer!]
  return:     [integer!]
] mysql-lib "mysql_real_connect"

mysql-close: make routine!
[
  mysql       [integer!]
] mysql-lib "mysql_close"

mysql-query: make routine!
[
  mysql       [integer!]
  query       [string!]
  return:     [integer!]
] mysql-lib "mysql_query"

mysql-ping: make routine!
[
  mysql       [integer!]
  return:     [integer!]
] mysql-lib "mysql_ping"

mysql-store-result: make routine!
[
  mysql       [integer!]
  return:     [integer!]
] mysql-lib "mysql_store_result"

mysql-errno: make routine!
[
    mysql [integer!]
    return: [integer!]
] mysql-lib "mysql_errno"

mysql-error: func [ num [integer!] /local ind msg]
[
    either (found? find mysql-error-map num)
    [
        ind: (index? find mysql-error-map num) - 1
        return (to-string pick mysql-error-map ind)
    ]
    [
        return "No matching error message found"
    ]
]

mysql-free-result: make routine!
[
  mysql_res   [integer!]
] mysql-lib "mysql_free_result"

mysql-num-rows: make routine!
[
   mysqlres [integer!]
   return: [integer!]
] mysql-lib "mysql_num_rows"

mysql-num-fields: make routine!
[
  mysqlres [integer!]
  return: [integer!]
] mysql-lib "mysql_num_fields"

mysql-database: make object! [
  connection: none
  initial: none
  sql-current-time: "now()"

  init: contract
  [
    [catch] {Initialize a database connection}
    user [string!] {User name.}
    passwd [string!] {The Password.}
    database[ string! ] {The database to connect to.}
    host[ string! ] {The host that runs the database.}
    nport [integer!] {The port to connect to}
  ]

  [ post [[not none? connection][not none? initial ] [ ( 0 = mysql-ping connection)]]]
  [ err ] ; Local variables
  [
    err: try
    [
      initial: mysql-init 0
      connection: mysql-connect initial host user passwd database nport 0 0
    ]
    if error? err [ probe disarm err ]
  ]

  auto-commit: contract
  [
    [catch] {Set autocommit on or off. Useless in current mysql versions.}
    commit? [ logic! ]
  ]
  [
  ];no conditions
  [ ];no locals
  [
  ];no logic yet

  query: contract
  [
    {Query the database with the specified query/queries}
    [catch]
    the-query [string!]
    /with-result {Return a result set.}
  ]
  [
    pre [ [ not none? connection ] [ not empty? the-query ] ]
  ]
  [
        errno errmsg
  ]
  [
    mysql-query connection the-query
        if (not ( 0 = mysql-errno connection))
        [
            errno: mysql-errno connection
            errmsg: copy mysql-error errno
            make error! rejoin [ {MySQL Error number } errno {.} newline errmsg ]
        ]

    if with-result
    [
      return result
    ]
  ]

  result: contract
  [
    {Return the result-set that is waiting from a previous query}
    [catch]
    /part {Return at most a part of the result set.}
    how-many {How many rows to return.}
  ]
  [
    pre [[ not none? connection] ]
  ]
  [
    result-set num-rows num-fields result-struct result-list
    result-row fields temp
  ]
  [
    result-set: mysql-store-result connection

        if (not ( 0 = mysql-errno connection))
        [
            errno: mysql-errno connection
            errmsg: copy mysql-error errno
            make error! rejoin [ {MySQL Error number } errno {.} newline errmsg ]
        ]


    if result-set = 0 [ return none ]

        if (not ( 0 = mysql-errno connection))
        [
            errno: mysql-errno connection
            errmsg: copy mysql-error errno
            make error! rejoin [ {MySQL Error number } errno {.} newline errmsg ]
        ]


    num-rows: mysql-num-rows result-set
    if num-rows = 0 [ return none ]

        if (not ( 0 = mysql-errno connection))
        [
            errno: mysql-errno connection
            errmsg: copy mysql-error errno
            make error! rejoin [ {MySQL Error number } errno {.} newline errmsg ]
        ]


    num-fields: mysql-num-fields result-set

        if (not ( 0 = mysql-errno connection))
        [
            errno: mysql-errno connection
            errmsg: copy mysql-error errno
            make error! rejoin [ {MySQL Error number } errno {.} newline errmsg ]
        ]


    result-list: make block! copy []

    routine-spec: make block!  [ mysql-res [integer!] return: ]
    result-struct-spec: make block! []

    for fields 1 num-fields 1
    [
      append result-struct-spec  to-word join "a" fields
      append/only  result-struct-spec copy  [string!]
    ]

    append/only routine-spec append/only copy [struct!] copy result-struct-spec

    mysql-fetch-row: make routine! :routine-spec mysql-lib "mysql_fetch_row"

    for fields 1 num-rows 1
    [
      temp: mysql-fetch-row result-set

            if (not ( 0 = mysql-errno connection))
            [
                errno: mysql-errno connection
                errmsg: copy mysql-error errno
                make error! rejoin [ {MySQL Error number } errno {.} newline errmsg ]
            ]

      result-row: copy second temp
      free temp
      append/only result-list result-row
    ]

    mysql-free-result result-set

        if (not ( 0 = mysql-errno connection))
        [
            errno: mysql-errno connection
            errmsg: copy mysql-error errno
            make error! rejoin [ {MySQL Error number } errno {.} newline errmsg ]
        ]


    either how-many
    [
      return copy/part result-list how-may
    ]
    [
      return result-list
    ]
  ]
  commit: contract
  [{Perform a commit on a queued set of statements.}[catch]]
  [ pre [ [ not none? connection] ] ]
  [ ];no local variables
  [ ]

  rollback: contract
  [ {Do a rollback on a set of transactions.} [catch] ]
  [ pre [ [ not none? connection] ] ]
  [ ] ;no local variables
  [ ]

  close-all: contract
  [ {Close all open database connections} [ catch]  ]
  [ pre [ [ not none? connection] ] ]
  [ ]
  [
    mysql-close connection
  ]
]