OpenACS

gustafn
committed
MAIN:gustafn:20130812215203
on 12 Aug 13
- use tcl 8.5 idioms
openacs-4/.../tcl/00-database-procs.tcl (+10 -9)
245 245
246 246     @see apm_package_supports_rdbms_p
247 247 } {
248 248     if { [lsearch $db_type_list [db_type]] != -1 } {
249 249         return 1
250 250     }
251 251
252 252     # DRB: Legacy package check - we allow installation of old aD Oracle 4.2 packages,
253 253     # though we don't guarantee that they work.
254 254
255 255     if { [db_type] eq "oracle" && [lsearch $db_type_list "oracle-8.1.6"] != -1 } {
256 256         return 1
257 257     }
258 258
259 259     return 0
260 260 }
261 261
262 262 ad_proc -private db_legacy_package_p { db_type_list } {
263 263     @return 1 if the package is a legacy package.  We can only tell for certain if it explicitly supports Oracle 8.1.6 rather than the OpenACS more general oracle.
264 264 } {
265       if { [lsearch $db_type_list "oracle-8.1.6"] != -1 } {
  265     if {"oracle-8.1.6" in $db_type_list} {
266 266         return 1
267 267     }
268 268     return 0
269 269 }
270 270
271 271 ad_proc -public db_version { } {
272 272     @return the RDBMS version (i.e. 8.1.6 is a recent Oracle version; 7.1 a
273 273     recent PostgreSQL version.
274 274 } {
275 275     return [nsv_get ad_database_version .]
276 276 }
277 277
278 278 ad_proc -public db_current_rdbms { } {
279 279     @return the current rdbms type and version.
280 280 } {
281 281     return [db_rdbms_create [db_type] [db_version]]
282 282 }
283 283
284 284 ad_proc -public db_known_database_types { } {
285 285     @return a list of three-element lists describing the database engines known
 
977 977     # (redundant) $dbn just so we can use it in the call to
978 978     # db_driverkey, so db_driverkey MUST support its -handle switch.
979 979     # --atp@piskorski.com, 2003/04/09 12:13 EDT
980 980
981 981     set sql [db_qd_replace_sql $statement_name $pre_sql]
982 982
983 983     # insert tcl variable values (Openacs - Dan)
984 984     if {$sql ne $pre_sql } {
985 985         set sql [uplevel $ulevel [list subst -nobackslashes $sql]]
986 986     }
987 987
988 988     set errno [catch {
989 989         upvar bind bind
990 990
991 991         if { [info exists bind] && [llength $bind] != 0 } {
992 992             if { [llength $bind] == 1 } {
993 993                 # $bind is an ns_set id:
994 994
995 995                 switch $driverkey {
996 996                     oracle {
997                           return [eval [list ns_ora $type $db -bind $bind $sql] $args]
  997                         return [ns_ora $type $db -bind $bind $sql {*}$args]
998 998                     }
999 999                     postgresql {
1000                           return [eval [list ns_pg_bind $type $db -bind $bind $sql]]
  1000                         return [ns_pg_bind $type $db -bind $bind $sql]
1001 1001                     }
1002 1002                     nsodbc {
1003                           return [eval [list ns_odbc_bind $type $db -bind $bind $sql]]
  1003                         return [ns_odbc_bind $type $db -bind $bind $sql]
1004 1004                     }
1005 1005                     default {
1006 1006                         error "Unknown database driver.  Bind variables not supported for this database."
1007 1007                     }
1008 1008                 }
1009 1009
1010 1010             } else {
1011 1011                 # $bind is a Tcl list, convert it to an ns_set:
1012 1012                 set bind_vars [ns_set create]
1013 1013                 foreach { name value } $bind {
1014 1014                     ns_set put $bind_vars $name $value
1015 1015                 }
1016 1016             }
1017 1017
1018 1018             switch $driverkey {
1019 1019                 oracle {
1020 1020                     # TODO: Using $args outside the list is
1021 1021                     # potentially bad here, depending on what is in
1022 1022                     # args and if the items contain any embedded
1023 1023                     # whitespace.  Or maybe it works fine.  But it's
1024 1024                     # hard to know.  Document or fix.
1025 1025                     # --atp@piskorski.com, 2003/04/09 15:33 EDT
1026 1026
1027                       return [eval [list ns_ora $type $db -bind $bind_vars $sql] $args]
  1027                     return [ns_ora $type $db -bind $bind_vars $sql {*}$args]
1028 1028                 }
1029 1029                 postgresql {
1030                       return [eval [list ns_pg_bind $type $db -bind $bind_vars $sql]]
  1030                     return [ns_pg_bind $type $db -bind $bind_vars $sql]
1031 1031                 }
1032 1032                 nsodbc {
1033                       return [eval [list ns_odbc_bind $type $db -bind $bind_vars $sql]]
  1033                     return [ns_odbc_bind $type $db -bind $bind_vars $sql]
1034 1034                 }
1035 1035                 default {
1036 1036                     error "Unknown database driver.  Bind variables not supported for this database."
1037 1037                 }
1038 1038             }
1039 1039
1040 1040         } else {
1041 1041             # Bind variables, if any, are defined solely as individual
1042 1042             # Tcl variables:
1043 1043
1044 1044             switch $driverkey {
1045 1045                 oracle {
1046 1046                     return [uplevel $ulevel [list ns_ora $type $db $sql] $args]
1047 1047                 }
1048 1048                 postgresql {
1049 1049                     return [uplevel $ulevel [list ns_pg_bind $type $db $sql]]
1050 1050                 }
1051 1051                 nsodbc {
1052 1052                     return [uplevel $ulevel [list ns_odbc_bind $type $db $sql]]
1053 1053                 }
 
3013 3013     <p>
3014 3014     <strong>TODO:</strong>
3015 3015     This proc should probably be changed to take a final
3016 3016     <code>file</code> argument, <em>only</em>, rather than the current
3017 3017     <code>args</code> variable length argument list.  Currently, it is
3018 3018     called only 4 places in OpenACS, and each place <code>args</code>,
3019 3019     if used at all, is always "<code>-file $file</code>".  However,
3020 3020     such a change might break custom code...  I'm not sure.
3021 3021     --atp@piskorski.com, 2003/04/09 11:39 EDT
3022 3022
3023 3023 } {
3024 3024     ad_arg_parser { bind file args } $args
3025 3025     set proc_name {db_blob_get_file}
3026 3026     set driverkey [db_driverkey $dbn]
3027 3027
3028 3028     set full_statement_name [db_qd_get_fullname $statement_name]
3029 3029
3030 3030     switch $driverkey {
3031 3031         oracle {
3032 3032             db_with_handle -dbn $dbn db {
3033                   eval [list db_exec_lob blob_get_file $db $full_statement_name $sql $file]
  3033                 db_exec_lob blob_get_file $db $full_statement_name $sql $file
3034 3034             }
3035 3035         }
3036 3036
3037 3037         postgresql {
3038 3038             db_with_handle -dbn $dbn db {
3039 3039                 db_exec_lob blob_select_file $db $full_statement_name $sql $file
3040 3040             }
3041 3041         }
3042 3042
3043 3043         nsodbc -
3044 3044         default {
3045 3045             error "$proc_name is not supported for this database."
3046 3046         }
3047 3047     }
3048 3048 }
3049 3049
3050 3050
3051 3051 ad_proc -public db_blob_get {{ -dbn "" } statement_name sql args } {
3052 3052     <strong>PostgreSQL only.</strong>
3053 3053
 
3158 3158         set original_type $type
3159 3159         set qtype 1row
3160 3160         ns_log Debug "db_exec_lob: file storage in use"
3161 3161     } else {
3162 3162         set qtype $type
3163 3163         ns_log Debug "db_exec_lob: blob storage in use"
3164 3164     }
3165 3165
3166 3166     set errno [catch {
3167 3167         upvar bind bind
3168 3168
3169 3169         # Below, note that 'ns_ora blob_get_file' takes 3 parameters,
3170 3170         # while 'ns_ora write_blob' takes only 2.  So if file is empty
3171 3171         # string (which it always will/should be for $qtype
3172 3172         # write_blob), we must not pass any 3rd parameter to the
3173 3173         # ns_ora command: --atp@piskorski.com, 2003/04/09 15:10 EDT
3174 3174
3175 3175         if { [info exists bind] && [llength $bind] != 0 } {
3176 3176             if { [llength $bind] == 1 } {
3177 3177                 if { $file eq "" } {
  3178                     # gn: not sure, why the eval was ever needed (4 times)
3178 3179                     set selection [eval [list ns_ora $qtype $db -bind $bind $sql]]
3179 3180                 } else {
3180 3181                     set selection [eval [list ns_ora $qtype $db -bind $bind $sql $file]]
3181 3182                 }
3182 3183
3183 3184             } else {
3184 3185                 set bind_vars [ns_set create]
3185 3186                 foreach { name value } $bind {
3186 3187                     ns_set put $bind_vars $name $value
3187 3188                 }
3188 3189                 if { $file eq "" } {
3189 3190                     set selection [eval [list ns_ora $qtype $db -bind $bind_vars $sql]]
3190 3191                 } else {
3191 3192                     set selection [eval [list ns_ora $qtype $db -bind $bind_vars $sql $file]]
3192 3193                 }
3193 3194             }
3194 3195
3195 3196         } else {
3196 3197             if { $file eq "" } {
3197 3198                 set selection [uplevel $ulevel [list ns_ora $qtype $db $sql]]