Index: openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl,v
diff -u -r1.25 -r1.26
--- openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl	8 Jun 2007 12:01:00 -0000	1.25
+++ openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl	11 Jun 2007 11:40:35 -0000	1.26
@@ -6,29 +6,203 @@
   @cvs-id $Id$
 }
 
-namespace eval ::xo::db::sql {
 
-  Object call
-  # during load, we do not have "package_plsql_args" available yet, so we do it by hand
-  call set oracle_all_package_functions {
-    select distinct package_name, object_name
-        from user_arguments args
-        where args.position > 0 and package_name is not null
+namespace eval ::xo::db {
+  ::xotcl::Object create require
+
+  require set postgresql_table_exists {select 1 from pg_tables   where tablename  = '$name'}
+  require set postgresql_view_exists  {select 1 from pg_views    where viewname   = '$name'}
+  require set postgresql_index_exists {select 1 from pg_indexes  where indexname  = '$name'}
+  require set oracle_table_exists     {select 1 from all_tables  where table_name = '$name'}
+  require set oracle_view_exists      {select 1 from all_views   where view_name  = '$name'}
+  require set oracle_index_exists     {select 1 from all_indexes where index_name = '$name'}
+
+  require proc table {name definition} {
+    if {[db_driverkey ""] eq "oracle"} {set name [string toupper $name]}
+    if {![db_0or1row [my qn ""] [subst [my set [db_driverkey ""]_table_exists]]]} {
+      #my log "--table $name does not exist, creating with $definition"
+      db_dml [my qn create-table-$name] "create table $name ($definition)"
+    }
   }
-  call set postgresql_all_package_functions {
-    select distinct 
-       substring(function from 0 for position('__' in function)) as package_name,
-       substring(function from position('__' in function)+2) as object_name 
-    from acs_function_args
+
+  require proc view {name definition} {
+    if {[db_driverkey ""] eq "oracle"} {set name [string toupper $name]}
+    if {![db_0or1row [my qn ""] [subst [my set [db_driverkey ""]_view_exists]]]} {
+      db_dml [my qn create-view-$name] "create view $name AS $definition"
+    }
   }
 
+  if {[db_driverkey ""] eq "oracle"} {
+    proc mk_sql_constraint_name {table att suffix} {
+      set name ${table}_${att}_$suffix
+      if {[string length $name]>30} {
+        set sl [string length $suffix]
+        set name [string range ${table}_${att}  0 [expr {28 - $sl}]]_$suffix
+      }
+      return [string toupper $name]
+    }
+  } else {
+    proc mk_sql_constraint_name {table att suffix} {
+      set name ${table}_${att}_$suffix
+      return $name
+    }
+  }
+
+  require proc index {-table -col {-using ""} {-unique false}} {
+    set colpart $col
+    regsub -all ", *" $colpart _ colpart
+    set suffix [expr {$unique ? "un_idx" : "idx"}]
+    set uniquepart [expr {$unique ? "UNIQUE" : ""}]
+    set name [::xo::db::mk_sql_constraint_name $table $colpart $suffix]
+    if {![db_0or1row [my qn ""] [subst [my set [db_driverkey ""]_index_exists]]]} {
+      set using [expr {$using ne "" ? "using $using" : ""}]
+      db_dml [my qn create-index-$name] \
+          "create $uniquepart index $name ON $table $using ($col)"
+    }
+  }
+
+  require proc package name {
+    if {[info command ::${name}::*] eq ""} {
+      set dir [ns_info tcllib]/../packages/$name
+      foreach file [glob $dir/tcl/*-procs.tcl] {
+        uplevel #1 source $file
+      }
+    }
+  }
+
   proc function_name {sql} {
     if {[db_driverkey ""] eq "oracle"} {return [string map [list "__" .] $sql]}
     return $sql
   }
 
-  Class DbPackage
+  ad_proc has_ltree {} {
+    Check, whether ltree is available (postgres only)
+  } {
+    ns_cache eval xotcl_object_cache ::xo::has_ltree {
+      if {[db_driverkey ""] eq "postgresql" && 
+          [db_string check_ltree "select count(*) from pg_proc where proname = 'ltree_in'"]} {
+        return 1
+      }
+      return 0
+    }
+  }
 
+  # we create the sql object
+  ::xotcl::Object create sql
+
+  
+  if {[db_driverkey ""] eq "postgresql"} {
+
+    # during load, we do not have "package_plsql_args" available yet, so we do it by hand
+    sql set all_package_functions {
+      select distinct 
+        substring(function from 0 for position('__' in function)) as package_name,
+        substring(function from position('__' in function)+2) as object_name 
+       from acs_function_args
+    }
+
+    sql proc map_datatype {type} {return $type}
+    sql proc datatype_constraint {type table att} {return ""}
+
+    sql proc select {
+      -vars:required 
+      -from:required 
+      -where:required 
+      {-groupby ""} 
+      {-limit ""} 
+      {-offset ""} 
+      {-start ""}
+      {-orderby ""}
+      {-map_function_names false}
+    } {
+      set offset_clause [expr {$offset  ne "" ? "OFFSET $offset" : ""}]
+      set limit_clause  [expr {$limit   ne "" ? "LIMIT $limit" : ""}]
+      set order_clause  [expr {$orderby ne "" ? "ORDER BY $orderby" : ""}]
+      set group_clause  [expr {$groupby ne "" ? "GROUP BY $groupby" : ""}]
+      return "SELECT $vars FROM $from WHERE $where $group_clause $order_clause $limit_clause"
+    }
+
+    sql proc date_trunc {field date} {
+      return "date_trunc('$field',$date)"
+    }
+    sql proc date_trunc_expression {field date date_string} {
+      return "date_trunc('$field',$date) = '$date_string'"
+    }
+
+  } else { ;# Oracle
+
+    sql set all_package_functions {
+      select distinct package_name, object_name
+        from user_arguments args
+        where args.position > 0 and package_name is not null
+    }
+
+    sql proc map_datatype {type} {
+      switch $type {
+        text {set type varchar2(4000)}
+        boolean {set type char(1)}
+      }
+      return $type
+    }
+    sql proc datatype_constraint {type table att} {
+      set constraint ""
+      switch $type {
+        boolean {
+          set cname [::xo::db::mk_sql_constraint_name $table $att _ck]
+          set constraint "constraint $cname check ($att in ('t','f'))"}
+      }
+      return $constraint
+    }
+
+    sql proc select {
+      -vars:required 
+      -from:required 
+      -where:required 
+      {-groupby ""} 
+      {-limit ""} 
+      {-offset ""} 
+      {-start ""}
+      {-orderby ""}
+      {-map_function_names false}
+    } {
+      # "-start" not used so far
+      set order_clause [expr {$orderby ne "" ? "ORDER BY $orderby" : ""}]
+      set group_clause [expr {$groupby ne "" ? "GROUP BY $groupby" : ""}]
+      if {$map_function_names} {set vars [::xo::db::function_name $vars]}
+      set sql "SELECT $vars FROM $from WHERE $where $group_clause"
+      if {$limit ne "" || $offset ne ""} {
+        if {$offset eq ""} {
+          set limit_clause "ROWNUM <= $limit"
+        } elseif {$limit eq ""} {
+          set limit_clause "ROWNUM >= $offset"
+        } else {
+          set limit_clause "ROWNUM BETWEEN $offset and [expr {$offset+$limit}]"
+        }
+        # for pagination, we will need an "inner" sort, such as 
+        # SELECT * FROM (SELECT ...., ROW_NUMBER() OVER (ORDER BY ...) R FROM table) WHERE R BETWEEN 0 and 100 
+        set sql "SELECT * FROM ($sql) WHERE $limit_clause $order_clause"
+      } else {
+        append sql " " $order_clause
+      }
+      my log "--returned sql = $sql"
+      return $sql
+    }
+    sql proc date_trunc {field date} {
+      return "to_char(trunc($date,'$field'), 'YYYY-MM-DD HH24:MI:SS')"
+    }
+    sql proc date_trunc_expression {field date date_string} {
+      return "trunc($date,'$field') = trunc(to_date('$date_string','YYYY-MM-DD'),'$field')"
+    }
+  }
+  sql proc since_interval_condition {var interval} {
+    set since [clock format [clock scan "-$interval"] -format "%Y-%m-%d %T"]
+    return "$var > TO_TIMESTAMP('$since','YYYY-MM-DD HH24:MI:SS')"
+  }
+}
+
+namespace eval ::xo::db {
+  Class create DbPackage
+
   # Some stored procs like content_item__new do currently not define null default values.
   # Therefore, we need - temporary - this ugly hack is used to keep
   # :required passing and to allow  the xowiki regression test to run. 
@@ -43,7 +217,7 @@
       DEFAULT_VALUE null SORT_ORDER null PRETTY_PLURAL null
     }
   }
-
+  
   DbPackage instproc sql-arguments {sql package_name object_name} {
     my array unset defined
     my set function_args [db_list_of_lists [my qn get_function_params] $sql]
@@ -60,20 +234,21 @@
     }
     return [join $psql_args ", "]
   }
-
+  
   DbPackage instproc psql-postgresql {package_name object_name full_statement_name} {
     set psql_args [my sql-arguments {
-	select args.arg_name, args.arg_default
-        from acs_function_args args
-        where args.function = upper(:package_name) || '__' || upper(:object_name)
-        order by function, arg_seq
+      select args.arg_name, args.arg_default
+      from acs_function_args args
+      where args.function = upper(:package_name) || '__' || upper(:object_name)
+      order by function, arg_seq
     } $package_name $object_name]
     my set sql [subst {
       select ${package_name}__${object_name}($psql_args)
     }]
     #return {ns_pg_bind 0or1row $db $sql}
     return {ns_set value [ns_pg_bind 0or1row $db $sql] 0}
   }
+  
   DbPackage instproc psql-oracle {package_name object_name full_statement_name} {
     # 
     # in Oracle, we have to distinguish between functions and procs
@@ -125,6 +300,7 @@
       }
     }
   }
+
   DbPackage instproc proc_body-oracle {} {
     return {
       #defined: [my array get defined]
@@ -144,7 +320,6 @@
     }
   }
 
-
   DbPackage instproc dbproc_nonposargs {object_name} {
     #
     # This method compiles a stored procedure into a xotcl method 
@@ -181,192 +356,16 @@
   }
  
   DbPackage proc create_all_functions {} {
-    db_foreach [my qn ""] [call set [db_driverkey ""]_all_package_functions] {
+    db_foreach [my qn ""] [::xo::db::sql set all_package_functions] {
       #if {![my isobject $package_name]} { DbPackage create $package_name }
       #$package_name dbproc_exportvars $object_name
-      set class_name [string tolower $package_name] 
+      set class_name ::xo::db::sql::[string tolower $package_name] 
       if {![my isobject $class_name]} { DbPackage create $class_name }
       $class_name dbproc_nonposargs [string tolower $object_name]
     }
   }
+  
   DbPackage create_all_functions
 }
 
 
-namespace eval ::xo::db {
-  # we create for the previously created namespace ::xo::db::sql 
-  # a few methods via the object ::xo::db::sql
-  ::xotcl::Object create sql
-
-  if {[db_driverkey ""] eq "postgresql"} {
-
-    sql proc map_datatype {type} {return $type}
-    sql proc datatype_constraint {type table att} {return ""}
-
-    sql proc select {
-      -vars:required 
-      -from:required 
-      -where:required 
-      {-groupby ""} 
-      {-limit ""} 
-      {-offset ""} 
-      {-start ""}
-      {-orderby ""}
-      {-map_function_names false}
-    } {
-      set offset_clause [expr {$offset  ne "" ? "OFFSET $offset" : ""}]
-      set limit_clause  [expr {$limit   ne "" ? "LIMIT $limit" : ""}]
-      set order_clause  [expr {$orderby ne "" ? "ORDER BY $orderby" : ""}]
-      set group_clause  [expr {$groupby ne "" ? "GROUP BY $groupby" : ""}]
-      return "SELECT $vars FROM $from WHERE $where $group_clause $order_clause $limit_clause"
-    }
-
-    sql proc date_trunc {field date} {
-      return "date_trunc('$field',$date)"
-    }
-    sql proc date_trunc_expression {field date date_string} {
-      return "date_trunc('$field',$date) = '$date_string'"
-    }
-
-  } else { ;# Oracle
-    sql proc map_datatype {type} {
-      switch $type {
-        text {set type varchar2(4000)}
-        boolean {set type char(1)}
-      }
-      return $type
-    }
-    sql proc datatype_constraint {type table att} {
-      set constraint ""
-      switch $type {
-        boolean {
-          set cname [::xo::db::mk_sql_constraint_name $table $att $ck]
-          set constraint "constraint $cname check ($att in ('t','f'))"}
-      }
-      return $constraint
-    }
-
-    sql proc select {
-      -vars:required 
-      -from:required 
-      -where:required 
-      {-groupby ""} 
-      {-limit ""} 
-      {-offset ""} 
-      {-start ""}
-      {-orderby ""}
-      {-map_function_names false}
-    } {
-      # "-start" not used so far
-      set order_clause [expr {$orderby ne "" ? "ORDER BY $orderby" : ""}]
-      set group_clause [expr {$groupby ne "" ? "GROUP BY $groupby" : ""}]
-      if {$map_function_names} {set vars [::xo::db::function_name $vars]}
-      set sql "SELECT $vars FROM $from WHERE $where $group_clause"
-      if {$limit ne "" || $offset ne ""} {
-        if {$offset eq ""} {
-          set limit_clause "ROWNUM <= $limit"
-        } elseif {$limit eq ""} {
-          set limit_clause "ROWNUM >= $offset"
-        } else {
-          set limit_clause "ROWNUM BETWEEN $offset and [expr {$offset+$limit}]"
-        }
-        # for pagination, we will need an "inner" sort, such as 
-        # SELECT * FROM (SELECT ...., ROW_NUMBER() OVER (ORDER BY ...) R FROM table) WHERE R BETWEEN 0 and 100 
-        set sql "SELECT * FROM ($sql) WHERE $limit_clause $order_clause"
-      } else {
-        append sql " " $order_clause
-      }
-      my log "--returned sql = $sql"
-      return $sql
-    }
-    sql proc date_trunc {field date} {
-      return "to_char(trunc($date,'$field'), 'YYYY-MM-DD HH24:MI:SS')"
-    }
-    sql proc date_trunc_expression {field date date_string} {
-      return "trunc($date,'$field') = trunc(to_date('$date_string','YYYY-MM-DD'),'$field')"
-    }
-  }
-  sql proc since_interval_condition {var interval} {
-    set since [clock format [clock scan "-$interval"] -format "%Y-%m-%d %T"]
-    return "$var > TO_TIMESTAMP('$since','YYYY-MM-DD HH24:MI:SS')"
-  }
-}
-
-
-namespace eval ::xo::db {
-  ::xotcl::Object create require
-
-  require set postgresql_table_exists {select 1 from pg_tables   where tablename  = '$name'}
-  require set postgresql_view_exists  {select 1 from pg_views    where viewname   = '$name'}
-  require set postgresql_index_exists {select 1 from pg_indexes  where indexname  = '$name'}
-  require set oracle_table_exists     {select 1 from all_tables  where table_name = '$name'}
-  require set oracle_view_exists      {select 1 from all_views   where view_name  = '$name'}
-  require set oracle_index_exists     {select 1 from all_indexes where index_name = '$name'}
-
-  require proc table {name definition} {
-    if {[db_driverkey ""] eq "oracle"} {set name [string toupper $name]}
-    if {![db_0or1row [my qn ""] [subst [my set [db_driverkey ""]_table_exists]]]} {
-      #my log "--table $name does not exist, creating with $definition"
-      db_dml [my qn create-table-$name] "create table $name ($definition)"
-    }
-  }
-
-  require proc view {name definition} {
-    if {[db_driverkey ""] eq "oracle"} {set name [string toupper $name]}
-    if {![db_0or1row [my qn ""] [subst [my set [db_driverkey ""]_view_exists]]]} {
-      db_dml [my qn create-view-$name] "create view $name AS $definition"
-    }
-  }
-
-  if {[db_driverkey ""] eq "oracle"} {
-    proc mk_sql_constraint_name {table att suffix} {
-      set name ${table}_${att}_$suffix
-      if {[string length $name]>30} {
-        set sl [string length $suffix]
-        set name [string range ${table}_${att}  0 [expr {28 - $sl}]]_$suffix
-      }
-      return [string toupper $name]
-    }
-  } else {
-    proc mk_sql_constraint_name {table att suffix} {
-      set name ${table}_${att}_$suffix
-      return $name
-    }
-  }
-
-  require proc index {-table -col {-using ""} {-unique false}} {
-    set colpart $col
-    regsub -all ", *" $colpart _ colpart
-    set suffix [expr {$unique ? "un_idx" : "idx"}]
-    set uniquepart [expr {$unique ? "UNIQUE" : ""}]
-    set name [::xo::db::mk_sql_constraint_name $table $colpart $suffix]
-    if {![db_0or1row [my qn ""] [subst [my set [db_driverkey ""]_index_exists]]]} {
-      set using [expr {$using ne "" ? "using $using" : ""}]
-      db_dml [my qn create-index-$name] \
-          "create $uniquepart index $name ON $table $using ($col)"
-    }
-  }
-
-  require proc package name {
-    if {[info command ::${name}::*] eq ""} {
-      set dir [ns_info tcllib]/../packages/$name
-      foreach file [glob $dir/tcl/*-procs.tcl] {
-        uplevel #1 source $file
-      }
-    }
-  }
-
-  ad_proc has_ltree {} {
-    Check, whether ltree is available (postgres only)
-  } {
-    ns_cache eval xotcl_object_cache ::xo::has_ltree {
-      if {[db_driverkey ""] eq "postgresql" && 
-          [db_string check_ltree "select count(*) from pg_proc where proname = 'ltree_in'"]} {
-        return 1
-      }
-      return 0
-    }
-  }
-
-}
-