You are viewing a plain text version of this content. The canonical link for it is here.
Posted to site-cvs@tcl.apache.org by mx...@apache.org on 2014/01/23 11:40:40 UTC
svn commit: r1560624 - in /tcl/rivet/branches/modular: ./ doc/ doc/xml/
rivet/packages/dio/ rivet/rivet-tcl/ src/apache-2/ src/request/
Author: mxmanghi
Date: Thu Jan 23 10:40:39 2014
New Revision: 1560624
URL: http://svn.apache.org/r1560624
Log:
* : merging latest changes from trunk
Added:
tcl/rivet/branches/modular/rivet/packages/dio/aida.tcl
- copied unchanged from r1560621, tcl/rivet/trunk/rivet/packages/dio/aida.tcl
tcl/rivet/branches/modular/rivet/packages/dio/dio_Tdbc.tcl
- copied unchanged from r1560621, tcl/rivet/trunk/rivet/packages/dio/dio_Tdbc.tcl
tcl/rivet/branches/modular/rivet/packages/dio/sql.tcl
- copied unchanged from r1560621, tcl/rivet/trunk/rivet/packages/dio/sql.tcl
tcl/rivet/branches/modular/rivet/rivet-tcl/lassign_array.tcl
- copied unchanged from r1560621, tcl/rivet/trunk/rivet/rivet-tcl/lassign_array.tcl
Modified:
tcl/rivet/branches/modular/ (props changed)
tcl/rivet/branches/modular/ChangeLog
tcl/rivet/branches/modular/Makefile.in
tcl/rivet/branches/modular/configure.ac
tcl/rivet/branches/modular/doc/ (props changed)
tcl/rivet/branches/modular/doc/xml/commands.xml
tcl/rivet/branches/modular/doc/xml/install.xml
tcl/rivet/branches/modular/rivet/packages/dio/dio.tcl
tcl/rivet/branches/modular/rivet/packages/dio/dio_Mysql.tcl
tcl/rivet/branches/modular/rivet/packages/dio/dio_Postgresql.tcl
tcl/rivet/branches/modular/rivet/packages/dio/pkgIndex.tcl
tcl/rivet/branches/modular/rivet/rivet-tcl/tclIndex
tcl/rivet/branches/modular/src/apache-2/mod_rivet.c
tcl/rivet/branches/modular/src/request/apache_request.c
Propchange: tcl/rivet/branches/modular/
------------------------------------------------------------------------------
Merged /tcl/rivet/trunk:r1538806-1560621
Modified: tcl/rivet/branches/modular/ChangeLog
URL: http://svn.apache.org/viewvc/tcl/rivet/branches/modular/ChangeLog?rev=1560624&r1=1560623&r2=1560624&view=diff
==============================================================================
--- tcl/rivet/branches/modular/ChangeLog (original)
+++ tcl/rivet/branches/modular/ChangeLog Thu Jan 23 10:40:39 2014
@@ -1,3 +1,53 @@
+2014-01-23 Massimo Manghi <mx...@apache.org>
+ * : merging latest changes from trunk
+
+2014-01-08 Massimo Manghi <mx...@apache.org>
+ * rivet/packages/dio/aida.tcl: adding aida.tcl experimental file
+ for a DIO compatible interface to TDBC.
+ * rivet/packages/dio/sql.tcl: now able to produce same basic SQL queries
+ ::DIO::Database class is doing now
+
+2013-12-19 Massimo Manghi <mx...@apache.org>
+ * rivet/packages/dio/dio_Postgresql.tcl: reindented and tabs converted to spaces
+ * rivet/packages/dio/sql.tcl: class DIO::Sql now returning basic SELECT SQL statements
+
+2013-12-18 Massimo Manghi <mx...@apache.org>
+ * rivet/packages/dio/sql.tcl: further developments. Class Sql is now able
+ to build an abstract representation of a SELECT query
+ * rivet/packages/dio/dio.tcl: typo in a comment
+
+2013-12-16 Massimo Manghi <mx...@apache.org>
+ * rivet/packages/dio/sql.tcl: trying to redesign rivet in order to comply with
+ Tdbc and aiming at making DIO a pure interface to Tdbc dropping the
+ dependency with DBMS specific drivers
+
+2013-12-13 Massimo Manghi <mx...@apache.org>
+ * rivet/packages/dio/dio_Tdbc.tcl: first version of Tdbc driver for DIO. This
+ class is able to execute basic queries and needs further development
+
+2013-12-08 Massimo Manghi <mx...@apache.org>
+ * configure.ac: version number bumped up to 2.1.4
+
+2013-12-06 Massimo Manghi <mx...@apache.org>
+ * rivet/packages/dio/dio_Postgres.tcl: minor changes (code indentation revised)
+ * rivet/packages/dio/dio_Tdbc.tcl: experimental support for the tdbc
+ abstraction library
+ * doc/xml/install.xml: the manual still suggested to call make install-packages,
+ whereas 'make install' does everything now as it was before 2.1.2
+
+2013-12-04 Massimo Manghi <mx...@apache.org>
+ * src/apache-2/apache_request.c: log message in ApacheRequest___parse()
+ commented out (Bug #55845)
+
+2013-12-03 Massimo Manghi <mx...@apache.org>
+ * src/apache-2/mod_rivet.c: Rivet template preprocessor symbols renamed in
+ the more expressive RIVET_TEMPLATE and RIVET_TCLFILE
+ * rivet/rivet-tcl/lassing_array.tcl: new command lassing_array taken
+ from DIO's result set class (inspired by Tclx)
+ * doc/xml/commands.xml: lassign_array documented in the manual
+ * rivet/packages/dio/dio.tcl: reformatted during analysis for supporting
+ tdbc based driver
+
2013-11-04 Massimo Manghi <mx...@apache.org>
* src/Makefile.am: this Makefile.am is now in charge for building mod_rivet
librivet.so and librivetparser.so. This fixes and problem with the 'distclean'
Modified: tcl/rivet/branches/modular/Makefile.in
URL: http://svn.apache.org/viewvc/tcl/rivet/branches/modular/Makefile.in?rev=1560624&r1=1560623&r2=1560624&view=diff
==============================================================================
--- tcl/rivet/branches/modular/Makefile.in (original)
+++ tcl/rivet/branches/modular/Makefile.in Thu Jan 23 10:40:39 2014
@@ -1,4 +1,4 @@
-# Makefile.in generated by automake 1.14 from Makefile.am.
+# Makefile.in generated by automake 1.13.3 from Makefile.am.
# @configure_input@
# Copyright (C) 1994-2013 Free Software Foundation, Inc.
@@ -94,7 +94,6 @@ DIST_COMMON = $(srcdir)/Makefile.in $(sr
README TODO tclconfig/compile tclconfig/config.guess \
tclconfig/config.sub tclconfig/depcomp tclconfig/install-sh \
tclconfig/missing tclconfig/ltmain.sh \
- $(top_srcdir)/tclconfig/compile \
$(top_srcdir)/tclconfig/config.guess \
$(top_srcdir)/tclconfig/config.sub \
$(top_srcdir)/tclconfig/install-sh \
@@ -451,8 +450,8 @@ $(ACLOCAL_M4): $(am__aclocal_m4_deps)
$(am__aclocal_m4_deps):
config.h: stamp-h1
- @test -f $@ || rm -f stamp-h1
- @test -f $@ || $(MAKE) $(AM_MAKEFLAGS) stamp-h1
+ @if test ! -f $@; then rm -f stamp-h1; else :; fi
+ @if test ! -f $@; then $(MAKE) $(AM_MAKEFLAGS) stamp-h1; else :; fi
stamp-h1: $(srcdir)/config.h.in $(top_builddir)/config.status
@rm -f stamp-h1
@@ -661,16 +660,10 @@ dist-xz: distdir
$(am__post_remove_distdir)
dist-tarZ: distdir
- @echo WARNING: "Support for shar distribution archives is" \
- "deprecated." >&2
- @echo WARNING: "It will be removed altogether in Automake 2.0" >&2
tardir=$(distdir) && $(am__tar) | compress -c >$(distdir).tar.Z
$(am__post_remove_distdir)
dist-shar: distdir
- @echo WARNING: "Support for distribution archives compressed with" \
- "legacy program 'compress' is deprecated." >&2
- @echo WARNING: "It will be removed altogether in Automake 2.0" >&2
shar $(distdir) | GZIP=$(GZIP_ENV) gzip -c >$(distdir).shar.gz
$(am__post_remove_distdir)
Modified: tcl/rivet/branches/modular/configure.ac
URL: http://svn.apache.org/viewvc/tcl/rivet/branches/modular/configure.ac?rev=1560624&r1=1560623&r2=1560624&view=diff
==============================================================================
--- tcl/rivet/branches/modular/configure.ac (original)
+++ tcl/rivet/branches/modular/configure.ac Thu Jan 23 10:40:39 2014
@@ -22,7 +22,7 @@ dnl
# so you can encode the package version directly into the source files.
#-----------------------------------------------------------------------
-AC_INIT([Rivet],[2.1.3])
+AC_INIT([Rivet],[2.1.4])
TEA_INIT([3.9])
AC_CONFIG_AUX_DIR(tclconfig)
Propchange: tcl/rivet/branches/modular/doc/
------------------------------------------------------------------------------
Merged /tcl/rivet/trunk/doc:r1538806-1560621
Modified: tcl/rivet/branches/modular/doc/xml/commands.xml
URL: http://svn.apache.org/viewvc/tcl/rivet/branches/modular/doc/xml/commands.xml?rev=1560624&r1=1560623&r2=1560624&view=diff
==============================================================================
--- tcl/rivet/branches/modular/doc/xml/commands.xml (original)
+++ tcl/rivet/branches/modular/doc/xml/commands.xml Thu Jan 23 10:40:39 2014
@@ -933,6 +933,37 @@ keyvalue_map(args) = 1 2 3 4 5</programl
</para>
</refsect1>
</refentry -->
+ <refentry id="lassign_array">
+ <refnamediv>
+ <refname>lassign_array</refname>
+ <refpurpose>Assign a list of values to array variables</refpurpose>
+ </refnamediv>
+ <refsynopsisdiv>
+ <cmdsynopsis>
+ <command>::rivet::lassign_array</command>
+ <arg>value_list</arg>
+ <arg>array_name</arg>
+ <arg>array_variables</arg>
+ </cmdsynopsis>
+ </refsynopsisdiv>
+ <refsect1>
+ <title>Description</title>
+ <para>
+ <command>lassign_array</command> is an utility command inspired by the same Tclx command.
+ The first argument is a list of values to be assigned to an array that must be
+ given as second argument. The remaining arguments are the array's variable names to take
+ as values the elements of the list. The command exploit Tcl's <command>foreach</command> construct
+ ability to scan multiple lists. Variables names don't matching values in the list are given an empty string.
+ </para>
+ <programlisting>::rivet::lassign_array {1 2 3 4} assigned_array a b c d
+parray assigned_array
+<emphasis role="strong">assigned_list</emphasis>
+assigned_list(a) = 1
+assigned_list(b) = 2
+assigned_list(c) = 3
+assigned_list(d) = 4</programlisting>
+ </refsect1>
+ </refentry>
<refentry id="lempty">
<refnamediv>
Modified: tcl/rivet/branches/modular/doc/xml/install.xml
URL: http://svn.apache.org/viewvc/tcl/rivet/branches/modular/doc/xml/install.xml?rev=1560624&r1=1560623&r2=1560624&view=diff
==============================================================================
--- tcl/rivet/branches/modular/doc/xml/install.xml (original)
+++ tcl/rivet/branches/modular/doc/xml/install.xml Thu Jan 23 10:40:39 2014
@@ -75,23 +75,23 @@ tar -xvf rivet-X.X.X.tar.gz</programlist
<substeps>
<step>
<para>
- On Linux or Unix systems, Rivet uses the standard <command>./configure ; make ; make install
- (; make install-packages)</command>
- sequence.
+ On Linux or Unix systems, Rivet uses the standard <command>./configure ; make ; make install</command>
+ sequence which installs to their target directories the Apache module, the binary libraries and the
+ Tcl code
</para>
<para>
There are several rivet specific options to configure that might be useful (or needed):
<variablelist>
- <varlistentry>
- <term>--with-tcl</term>
- <listitem>
- <para>
- This points to the directory where the
- <filename>tclConfig.sh</filename> file is located.
- </para>
- </listitem>
- </varlistentry>
- <varlistentry>
+ <varlistentry>
+ <term>--with-tcl</term>
+ <listitem>
+ <para>
+ This points to the directory where the
+ <filename>tclConfig.sh</filename> file is located.
+ </para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
<term>--with-tclsh</term>
<listitem>
<para>This points to the location of the
Modified: tcl/rivet/branches/modular/rivet/packages/dio/dio.tcl
URL: http://svn.apache.org/viewvc/tcl/rivet/branches/modular/rivet/packages/dio/dio.tcl?rev=1560624&r1=1560623&r2=1560624&view=diff
==============================================================================
--- tcl/rivet/branches/modular/rivet/packages/dio/dio.tcl (original)
+++ tcl/rivet/branches/modular/rivet/packages/dio/dio.tcl Thu Jan 23 10:40:39 2014
@@ -6,7 +6,7 @@
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
-# http://www.apache.org/licenses/LICENSE-2.0
+# http://www.apache.org/licenses/LICENSE-2.0
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
@@ -26,8 +26,8 @@ proc handle {interface args} {
set obj \#auto
set first [lindex $args 0]
if {![lempty $first] && [string index $first 0] != "-"} {
- set obj [lindex $args 0]
- set args [lreplace $args 0 0]
+ set obj [lindex $args 0]
+ set args [lreplace $args 0 0]
}
uplevel \#0 package require dio_$interface
return [uplevel \#0 ::DIO::$interface $obj $args]
@@ -38,11 +38,11 @@ proc handle {interface args} {
##
::itcl::class Database {
constructor {args} {
- eval configure $args
+ eval configure $args
}
destructor {
- close
+ close
}
#
@@ -51,7 +51,7 @@ proc handle {interface args} {
# result object.
#
protected method result {interface args} {
- return [eval uplevel \#0 ::DIO::${interface}Result \#auto $args]
+ return [eval uplevel \#0 ::DIO::${interface}Result \#auto $args]
}
#
@@ -59,8 +59,8 @@ proc handle {interface args} {
# quote characters preceded by a backslash
#
method quote {string} {
- regsub -all {'} $string {\'} string
- return $string
+ regsub -all {'} $string {\'} string
+ return $string
}
#
@@ -72,92 +72,92 @@ proc handle {interface args} {
#
protected method build_select_query {args} {
- set bool AND
- set first 1
- set req ""
- set myTable $table
- set what "*"
-
- # for each argument passed us...
- # (we go by integers because we mess with the index based on
- # what we find)
- for {set i 0} {$i < [llength $args]} {incr i} {
- # fetch the argument we're currently processing
- set elem [lindex $args $i]
-
- switch -- [::string tolower $elem] {
- "-and" {
- # -and -- switch to AND-style processing
- set bool AND
- }
-
- "-or" {
- # -or -- switch to OR-style processing
- set bool OR
- }
-
- "-table" {
- # -table -- identify which table the query is about
- set myTable [lindex $args [incr i]]
- }
-
- "-select" {
- # -select -
- set what [lindex $args [incr i]]
- }
-
- default {
- # it wasn't -and, -or, -table, or -select...
-
- # if the first character of the element is a dash,
- # it's a field name and a value
-
- if {[::string index $elem 0] == "-"} {
- set field [::string range $elem 1 end]
- set elem [lindex $args [incr i]]
-
- # if it's the first field being processed, append
- # WHERE to the SQL request we're generating
- if {$first} {
- append req " WHERE"
- set first 0
- } else {
- # it's not the first variable in the comparison
- # expression, so append the boolean state, either
- # AND or OR
- append req " $bool"
- }
-
- # convert any asterisks to percent signs in the
- # value field
- regsub -all {\*} $elem {%} elem
-
- # if there is a percent sign in the value
- # field now (having been there originally or
- # mapped in there a moment ago), the SQL aspect
- # is appended with a "field LIKE value"
-
- if {[::string first {%} $elem] != -1} {
- append req " $field LIKE [makeDBFieldValue $myTable $field $elem]"
- } elseif {[regexp {^([<>]) *([0-9.]*)$} $elem _ fn val]} {
- # value starts with <, or >, then space,
- # and a something
- append req " $field$fn$val"
- } elseif {[regexp {^([<>]=) *([0-9.]*)$} $elem _ fn val]} {
- # value starts with <= or >=, space, and something.
- append req " $field$fn$val"
- } else {
- # otherwise it's a straight key=value comparison
- append req " $field=[makeDBFieldValue $myTable $field $elem]"
- }
-
- continue
- }
- append req " $elem"
- }
- }
- }
- return "select $what from $myTable $req"
+ set bool AND
+ set first 1
+ set req ""
+ set myTable $table
+ set what "*"
+
+ # for each argument passed us...
+ # (we go by integers because we mess with the index based on
+ # what we find)
+ for {set i 0} {$i < [llength $args]} {incr i} {
+ # fetch the argument we're currently processing
+ set elem [lindex $args $i]
+
+ switch -- [::string tolower $elem] {
+ "-and" {
+ # -and -- switch to AND-style processing
+ set bool AND
+ }
+
+ "-or" {
+ # -or -- switch to OR-style processing
+ set bool OR
+ }
+
+ "-table" {
+ # -table -- identify which table the query is about
+ set myTable [lindex $args [incr i]]
+ }
+
+ "-select" {
+ # -select -
+ set what [lindex $args [incr i]]
+ }
+
+ default {
+ # it wasn't -and, -or, -table, or -select...
+
+ # if the first character of the element is a dash,
+ # it's a field name and a value
+
+ if {[::string index $elem 0] == "-"} {
+ set field [::string range $elem 1 end]
+ set elem [lindex $args [incr i]]
+
+ # if it's the first field being processed, append
+ # WHERE to the SQL request we're generating
+ if {$first} {
+ append req " WHERE"
+ set first 0
+ } else {
+ # it's not the first variable in the comparison
+ # expression, so append the boolean state, either
+ # AND or OR
+ append req " $bool"
+ }
+
+ # convert any asterisks to percent signs in the
+ # value field
+ regsub -all {\*} $elem {%} elem
+
+ # if there is a percent sign in the value
+ # field now (having been there originally or
+ # mapped in there a moment ago), the SQL aspect
+ # is appended with a "field LIKE value"
+
+ if {[::string first {%} $elem] != -1} {
+ append req " $field LIKE [makeDBFieldValue $myTable $field $elem]"
+ } elseif {[regexp {^([<>]) *([0-9.]*)$} $elem _ fn val]} {
+ # value starts with <, or >, then space,
+ # and a something
+ append req " $field$fn$val"
+ } elseif {[regexp {^([<>]=) *([0-9.]*)$} $elem _ fn val]} {
+ # value starts with <= or >=, space, and something.
+ append req " $field$fn$val"
+ } else {
+ # otherwise it's a straight key=value comparison
+ append req " $field=[makeDBFieldValue $myTable $field $elem]"
+ }
+
+ continue
+ }
+ append req " $elem"
+ }
+ }
+ }
+ return "select $what from $myTable $req"
}
#
@@ -168,17 +168,17 @@ proc handle {interface args} {
# coming from the array
#
protected method build_insert_query {arrayName fields {myTable ""}} {
- upvar 1 $arrayName array
+ upvar 1 $arrayName array
- if {[lempty $myTable]} { set myTable $table }
- set vals [::list]
- set vars [::list]
- foreach field $fields {
- if {![info exists array($field)]} { continue }
- lappend vars "$field"
- lappend vals "[makeDBFieldValue $myTable $field $array($field)]"
- }
- return "insert into $myTable ([join $vars {,}]) VALUES ([join $vals {,}])"
+ if {[lempty $myTable]} { set myTable $table }
+ set vals [::list]
+ set vars [::list]
+ foreach field $fields {
+ if {![info exists array($field)]} { continue }
+ lappend vars "$field"
+ lappend vals "[makeDBFieldValue $myTable $field $array($field)]"
+ }
+ return "insert into $myTable ([join $vars {,}]) VALUES ([join $vals {,}])"
}
#
@@ -192,14 +192,14 @@ proc handle {interface args} {
# you might update a lot more than you bargained for
#
protected method build_update_query {arrayName fields {myTable ""}} {
- upvar 1 $arrayName array
- if {[lempty $myTable]} { set myTable $table }
- set string [::list]
- foreach field $fields {
- if {![info exists array($field)]} { continue }
- lappend string "$field=[makeDBFieldValue $myTable $field $array($field)]"
- }
- return "update $myTable SET [join $string {,}]"
+ upvar 1 $arrayName array
+ if {[lempty $myTable]} { set myTable $table }
+ set string [::list]
+ foreach field $fields {
+ if {![info exists array($field)]} { continue }
+ lappend string "$field=[makeDBFieldValue $myTable $field $array($field)]"
+ }
+ return "update $myTable SET [join $string {,}]"
}
#
@@ -209,10 +209,10 @@ proc handle {interface args} {
# arguments, into the named array. From TclX.
#
protected method lassign_array {list arrayName args} {
- upvar 1 $arrayName array
- foreach elem $list field $args {
- set array($field) $elem
- }
+ upvar 1 $arrayName array
+ foreach elem $list field $args {
+ set array($field) $elem
+ }
}
#
@@ -221,8 +221,8 @@ proc handle {interface args} {
# variable to the string.
#
protected method configure_variable {varName string} {
- if {[lempty $string]} { return [cget -$varName] }
- configure -$varName $string
+ if {[lempty $string]} { return [cget -$varName] }
+ configure -$varName $string
}
#
@@ -232,18 +232,18 @@ proc handle {interface args} {
# together.
#
protected method build_key_where_clause {myKeyfield myKey} {
- ## If we're not using multiple keyfields, just return a simple
- ## where clause.
- if {[llength $myKeyfield] < 2} {
- return " WHERE $myKeyfield = [makeDBFieldValue $table $myKeyfield $myKey]"
- }
-
- # multiple fields, construct it as a where-and
- set req " WHERE 1 = 1"
- foreach field $myKeyfield key $myKey {
- append req " AND $field = [makeDBFieldValue $table $field $key]"
- }
- return $req
+ ## If we're not using multiple keyfields, just return a simple
+ ## where clause.
+ if {[llength $myKeyfield] < 2} {
+ return " WHERE $myKeyfield = [makeDBFieldValue $table $myKeyfield $myKey]"
+ }
+
+ # multiple fields, construct it as a where-and
+ set req " WHERE 1 = 1"
+ foreach field $myKeyfield key $myKey {
+ append req " AND $field = [makeDBFieldValue $table $field $key]"
+ }
+ return $req
}
##
@@ -257,51 +257,51 @@ proc handle {interface args} {
# values as a list
##
method makekey {arrayName {myKeyfield ""}} {
- if {[lempty $myKeyfield]} { set myKeyfield $keyfield }
- if {[lempty $myKeyfield]} {
- return -code error "No -keyfield specified in object"
- }
- upvar 1 $arrayName array
-
- ## If we're not using multiple keyfields, we want to check and see
- ## if we're using auto keys. If we are, create a new key and
- ## return it. If not, just return the value of the single keyfield
- ## in the array.
- if {[llength $myKeyfield] < 2} {
- if {$autokey} {
- set array($myKeyfield) [$this nextkey]
- } else {
- if {![info exists array($myKeyfield)]} {
- return -code error \
- "${arrayName}($myKeyfield) does not exist"
- }
- }
- return $array($myKeyfield)
- }
-
- ## We're using multiple keys. Return a list of all the keyfield
- ## values.
- foreach field $myKeyfield {
- if {![info exists array($field)]} {
- return -code error "$field does not exist in $arrayName"
- }
- lappend key $array($field)
- }
- return $key
+ if {[lempty $myKeyfield]} { set myKeyfield $keyfield }
+ if {[lempty $myKeyfield]} {
+ return -code error "No -keyfield specified in object"
+ }
+ upvar 1 $arrayName array
+
+ ## If we're not using multiple keyfields, we want to check and see
+ ## if we're using auto keys. If we are, create a new key and
+ ## return it. If not, just return the value of the single keyfield
+ ## in the array.
+ if {[llength $myKeyfield] < 2} {
+ if {$autokey} {
+ set array($myKeyfield) [$this nextkey]
+ } else {
+ if {![info exists array($myKeyfield)]} {
+ return -code error \
+ "${arrayName}($myKeyfield) does not exist"
+ }
+ }
+ return $array($myKeyfield)
+ }
+
+ ## We're using multiple keys. Return a list of all the keyfield
+ ## values.
+ foreach field $myKeyfield {
+ if {![info exists array($field)]} {
+ return -code error "$field does not exist in $arrayName"
+ }
+ lappend key $array($field)
+ }
+ return $key
}
method destroy {} {
- ::itcl::delete object $this
+ ::itcl::delete object $this
}
#
# string - execute a SQL request and only return a string of one row.
#
method string {req} {
- set res [exec $req]
- $res next -list val
- $res destroy
- return $val
+ set res [exec $req]
+ $res next -list val
+ $res destroy
+ return $val
}
#
@@ -309,13 +309,13 @@ proc handle {interface args} {
# row returned.
#
method list {req} {
- set res [exec $req]
- set list ""
- $res forall -list line {
- lappend list [lindex $line 0]
- }
- $res destroy
- return $list
+ set res [exec $req]
+ set list ""
+ $res forall -list line {
+ lappend list [lindex $line 0]
+ }
+ $res destroy
+ return $list
}
#
@@ -324,11 +324,11 @@ proc handle {interface args} {
# the values
#
method array {req arrayName} {
- upvar 1 $arrayName $arrayName
- set res [exec $req]
- set ret [$res next -array $arrayName]
- $res destroy
- return $ret
+ upvar 1 $arrayName $arrayName
+ set res [exec $req]
+ set ret [$res next -array $arrayName]
+ $res destroy
+ return $ret
}
#
@@ -337,23 +337,23 @@ proc handle {interface args} {
# matching values, executing the specified code body for each, in turn.
#
method forall {req arrayName body} {
- upvar 1 $arrayName $arrayName
+ upvar 1 $arrayName $arrayName
- set res [exec $req]
+ set res [exec $req]
- $res forall -array $arrayName {
- uplevel 1 $body
+ $res forall -array $arrayName {
+ uplevel 1 $body
}
- if {[$res error]} {
- set errinf [$res errorinfo]
- $res destroy
- return -code error "Got '$errinf' executing '$req'"
- }
+ if {[$res error]} {
+ set errinf [$res errorinfo]
+ $res destroy
+ return -code error "Got '$errinf' executing '$req'"
+ }
set ret [$res numrows]
- $res destroy
- return $ret
+ $res destroy
+ return $ret
}
#
@@ -366,21 +366,21 @@ proc handle {interface args} {
# determined.
#
protected method table_check {list {tableVar myTable} {keyVar myKeyfield}} {
- upvar 1 $tableVar $tableVar $keyVar $keyVar
- set data(-table) $table
- set data(-keyfield) $keyfield
- ::array set data $list
-
- if {[lempty $data(-table)]} {
- return -code error -errorcode missing_table "-table not specified in DIO object"
- }
- set $tableVar $data(-table)
-
- if {[lempty $data(-keyfield)]} {
- return -code error -errorcode missing_keyfield "-keyfield not specified in DIO object"
- }
+ upvar 1 $tableVar $tableVar $keyVar $keyVar
+ set data(-table) $table
+ set data(-keyfield) $keyfield
+ ::array set data $list
+
+ if {[lempty $data(-table)]} {
+ return -code error -errorcode missing_table "-table not specified in DIO object"
+ }
+ set $tableVar $data(-table)
- set $keyVar $data(-keyfield)
+ if {[lempty $data(-keyfield)]} {
+ return -code error -errorcode missing_keyfield "-keyfield not specified in DIO object"
+ }
+
+ set $keyVar $data(-keyfield)
}
#
@@ -389,13 +389,13 @@ proc handle {interface args} {
# autokey, there can't be more than one key.
#
protected method key_check {myKeyfield myKey} {
- if {[llength $myKeyfield] < 2} { return }
- if {$autokey} {
- return -code error "Cannot have autokey and multiple keyfields"
- }
- if {[llength $myKeyfield] != [llength $myKey]} {
- return -code error "Bad key length."
- }
+ if {[llength $myKeyfield] < 2} { return }
+ if {$autokey} {
+ return -code error "Cannot have autokey and multiple keyfields"
+ }
+ if {[llength $myKeyfield] != [llength $myKey]} {
+ return -code error "Bad key length."
+ }
}
#
@@ -404,23 +404,23 @@ proc handle {interface args} {
# the key into the array
#
method fetch {key arrayName args} {
- table_check $args
- key_check $myKeyfield $key
- upvar 1 $arrayName $arrayName
- set req "select * from $myTable"
- append req [build_key_where_clause $myKeyfield $key]
-
- set res [$this exec $req]
- if {[$res error]} {
- set errinf [$res errorinfo]
- $res destroy
- return -code error "Got '$errinf' executing '$req'"
- }
- set rows_found [expr [$res numrows] > 0]
- $res next -array $arrayName
- $res destroy
+ table_check $args
+ key_check $myKeyfield $key
+ upvar 1 $arrayName $arrayName
+ set req "select * from $myTable"
+ append req [build_key_where_clause $myKeyfield $key]
+
+ set res [$this exec $req]
+ if {[$res error]} {
+ set errinf [$res errorinfo]
+ $res destroy
+ return -code error "Got '$errinf' executing '$req'"
+ }
+ set rows_found [expr [$res numrows] > 0]
+ $res next -array $arrayName
+ $res destroy
- return $rows_found
+ return $rows_found
}
#
@@ -429,29 +429,29 @@ proc handle {interface args} {
# corresponding table entry.
#
method store {arrayName args} {
- table_check $args
- upvar 1 $arrayName $arrayName $arrayName array
- if {[llength $myKeyfield] > 1 && $autokey} {
- return -code error "Cannot have autokey and multiple keyfields"
- }
-
- set key [makekey $arrayName $myKeyfield]
- set req "select * from $myTable"
- append req [build_key_where_clause $myKeyfield $key]
- set res [exec $req]
- if {[$res error]} {
- set errinf [$res errorinfo]
- $res destroy
- return -code error "Got '$errinf' executing '$req'"
- }
- set numrows [$res numrows]
- $res destroy
+ table_check $args
+ upvar 1 $arrayName $arrayName $arrayName array
+ if {[llength $myKeyfield] > 1 && $autokey} {
+ return -code error "Cannot have autokey and multiple keyfields"
+ }
- if {$numrows} {
+ set key [makekey $arrayName $myKeyfield]
+ set req "select * from $myTable"
+ append req [build_key_where_clause $myKeyfield $key]
+ set res [exec $req]
+ if {[$res error]} {
+ set errinf [$res errorinfo]
+ $res destroy
+ return -code error "Got '$errinf' executing '$req'"
+ }
+ set numrows [$res numrows]
+ $res destroy
+
+ if {$numrows} {
$this update $arrayName {*}$args
- } else {
+ } else {
$this insert $myTable $arrayName
- }
+ }
return 1
}
@@ -461,27 +461,27 @@ proc handle {interface args} {
# an insert
#
method update {arrayName args} {
- table_check $args
- upvar 1 $arrayName $arrayName $arrayName array
+ table_check $args
+ upvar 1 $arrayName $arrayName $arrayName array
- set key [makekey $arrayName $myKeyfield]
+ set key [makekey $arrayName $myKeyfield]
- set fields [::array names array]
- set req [build_update_query array $fields $myTable]
- append req [build_key_where_clause $myKeyfield $key]
-
- set res [exec $req]
- if {[$res error]} {
- set errinf [$res errorinfo]
- $res destroy
- return -code error "Got '$errinf' executing '$req'"
- }
-
- # this doesn't work on postgres, you've got to use cmdRows,
- # we need to figure out what to do with this
- set numrows [$res numrows]
- $res destroy
- return $numrows
+ set fields [::array names array]
+ set req [build_update_query array $fields $myTable]
+ append req [build_key_where_clause $myKeyfield $key]
+
+ set res [exec $req]
+ if {[$res error]} {
+ set errinf [$res errorinfo]
+ $res destroy
+ return -code error "Got '$errinf' executing '$req'"
+ }
+
+ # this doesn't work on postgres, you've got to use cmdRows,
+ # we need to figure out what to do with this
+ set numrows [$res numrows]
+ $res destroy
+ return $numrows
}
#
@@ -493,26 +493,26 @@ proc handle {interface args} {
# want to change the value of a key field
#
method update_with_explicit_key {key arrayName args} {
- table_check $args
- key_check $myKeyfield $key
- upvar 1 $arrayName $arrayName $arrayName array
-
- set fields [::array names array]
- set req [build_update_query array $fields $myTable]
- append req [build_key_where_clause $myKeyfield $key]
-
- set res [exec $req]
- if {[$res error]} {
- set errinf [$res errorinfo]
- $res destroy
- return -code error "Got '$errinf' executing '$req'"
- }
-
- # this doesn't work on postgres, you've got to use cmdRows,
- # we need to figure out what to do with this
- set numrows [$res numrows]
- $res destroy
- return $numrows
+ table_check $args
+ key_check $myKeyfield $key
+ upvar 1 $arrayName $arrayName $arrayName array
+
+ set fields [::array names array]
+ set req [build_update_query array $fields $myTable]
+ append req [build_key_where_clause $myKeyfield $key]
+
+ set res [exec $req]
+ if {[$res error]} {
+ set errinf [$res errorinfo]
+ $res destroy
+ return -code error "Got '$errinf' executing '$req'"
+ }
+
+ # this doesn't work on postgres, you've got to use cmdRows,
+ # we need to figure out what to do with this
+ set numrows [$res numrows]
+ $res destroy
+ return $numrows
}
#
@@ -521,54 +521,54 @@ proc handle {interface args} {
# an insert -- this shouldn't require fields, it's broken
#
method insert {table arrayName} {
- upvar 1 $arrayName $arrayName $arrayName array
- set req [build_insert_query array [::array names array] $table]
+ upvar 1 $arrayName $arrayName $arrayName array
+ set req [build_insert_query array [::array names array] $table]
- set res [exec $req]
- if {[$res error]} {
- set errinf [$res errorinfo]
- $res destroy
- return -code error "Got '$errinf' executing '$req'"
- }
- $res destroy
- return 1
+ set res [exec $req]
+ if {[$res error]} {
+ set errinf [$res errorinfo]
+ $res destroy
+ return -code error "Got '$errinf' executing '$req'"
+ }
+ $res destroy
+ return 1
}
#
# delete - delete matching record from the specified table
#
method delete {key args} {
- table_check $args
- set req "DELETE FROM $myTable"
- append req [build_key_where_clause $myKeyfield $key]
-
- set res [exec $req]
- if {[$res error]} {
- set errinf [$res errorinfo]
- $res destroy
- return -code error "Got '$errinf' executing '$req'"
- }
+ table_check $args
+ set req "DELETE FROM $myTable"
+ append req [build_key_where_clause $myKeyfield $key]
+
+ set res [exec $req]
+ if {[$res error]} {
+ set errinf [$res errorinfo]
+ $res destroy
+ return -code error "Got '$errinf' executing '$req'"
+ }
- set n_deleted_rows [$res numrows]
- $res destroy
- return $n_deleted_rows
+ set n_deleted_rows [$res numrows]
+ $res destroy
+ return $n_deleted_rows
}
#
- # keys - return all keys in a tbale
+ # keys - return all keys in a table
#
method keys {args} {
- table_check $args
- set req "select * from $myTable"
- set obj [$this exec $req]
-
- set keys ""
- $obj forall -array a {
- lappend keys [makekey a $myKeyfield]
- }
- $obj destroy
+ table_check $args
+ set req "select * from $myTable"
+ set obj [$this exec $req]
+
+ set keys ""
+ $obj forall -array a {
+ lappend keys [makekey a $myKeyfield]
+ }
+ $obj destroy
- return $keys
+ return $keys
}
#
@@ -576,8 +576,8 @@ proc handle {interface args} {
# build_select_query style and return the result handle.
#
method search {args} {
- set req [eval build_select_query $args]
- return [exec $req]
+ set req [eval build_select_query $args]
+ return [exec $req]
}
#
@@ -596,15 +596,15 @@ proc handle {interface args} {
}
}
- return [string "select count(*) from $myTable"]
+ return [string "select count(*) from $myTable"]
}
method makeDBFieldValue {table_name field_name val} {
- return "'[quote $val]'"
+ return "'[quote $val]'"
}
method registerSpecialField {table_name field_name type} {
- set specialFields(${table_name}@${field_name}) $type
+ set specialFields(${table_name}@${field_name}) $type
}
##
@@ -635,28 +635,28 @@ proc handle {interface args} {
protected variable specialFields
- public variable interface ""
- public variable errorinfo ""
+ public variable interface ""
+ public variable errorinfo ""
- public variable db ""
- public variable table ""
- public variable sequence ""
-
- public variable user ""
- public variable pass ""
- public variable host ""
- public variable port ""
-
- public variable keyfield "" {
- if {[llength $keyfield] > 1 && $autokey} {
- return -code error "Cannot have autokey and multiple keyfields"
- }
- }
-
- public variable autokey 0 {
- if {[llength $keyfield] > 1 && $autokey} {
- return -code error "Cannot have autokey and multiple keyfields"
- }
+ public variable db ""
+ public variable table ""
+ public variable sequence ""
+
+ public variable user ""
+ public variable pass ""
+ public variable host ""
+ public variable port ""
+
+ public variable keyfield "" {
+ if {[llength $keyfield] > 1 && $autokey} {
+ return -code error "Cannot have autokey and multiple keyfields"
+ }
+ }
+
+ public variable autokey 0 {
+ if {[llength $keyfield] > 1 && $autokey} {
+ return -code error "Cannot have autokey and multiple keyfields"
+ }
}
} ; ## ::itcl::class Database
@@ -666,13 +666,13 @@ proc handle {interface args} {
#
::itcl::class Result {
constructor {args} {
- eval configure $args
+ eval configure $args
}
destructor { }
method destroy {} {
- ::itcl::delete object $this
+ ::itcl::delete object $this
}
#
@@ -681,8 +681,8 @@ proc handle {interface args} {
# variable to the string.
#
protected method configure_variable {varName string} {
- if {[lempty $string]} { return [cget -$varName] }
- configure -$varName $string
+ if {[lempty $string]} { return [cget -$varName] }
+ configure -$varName $string
}
#
@@ -692,10 +692,10 @@ proc handle {interface args} {
# arguments, into the named array. From TclX.
#
protected method lassign_array {list arrayName args} {
- upvar 1 $arrayName array
- foreach elem $list field $args {
- set array($field) $elem
- }
+ upvar 1 $arrayName array
+ foreach elem $list field $args {
+ set array($field) $elem
+ }
}
#
@@ -703,100 +703,100 @@ proc handle {interface args} {
# to the specified row ID
#
method seek {newrowid} {
- set rowid $newrowid
+ set rowid $newrowid
}
method cache {{size "all"}} {
- set cacheSize $size
- if {$size == "all"} { set cacheSize $numrows }
+ set cacheSize $size
+ if {$size == "all"} { set cacheSize $numrows }
- ## Delete the previous cache array.
- catch {unset cacheArray}
+ ## Delete the previous cache array.
+ catch {unset cacheArray}
- set autostatus $autocache
- set currrow $rowid
- set autocache 1
- seek 0
- set i 0
- while {[next -list list]} {
- if {[incr i] >= $cacheSize} { break }
- }
- set autocache $autostatus
- seek $currrow
- set cached 1
+ set autostatus $autocache
+ set currrow $rowid
+ set autocache 1
+ seek 0
+ set i 0
+ while {[next -list list]} {
+ if {[incr i] >= $cacheSize} { break }
+ }
+ set autocache $autostatus
+ seek $currrow
+ set cached 1
}
#
# forall -- walk the result object, executing the code body over it
#
method forall {type varName body} {
- upvar 1 $varName $varName
- set currrow $rowid
- seek 0
- while {[next $type $varName]} {
- uplevel 1 $body
- }
- set rowid $currrow
- return
+ upvar 1 $varName $varName
+ set currrow $rowid
+ seek 0
+ while {[next $type $varName]} {
+ uplevel 1 $body
+ }
+ set rowid $currrow
+ return
}
method next {type {varName ""}} {
- set return 1
- if {![lempty $varName]} {
- upvar 1 $varName var
- set return 0
- }
-
- catch {unset var}
-
- set list ""
- ## If we have a cached result for this row, use it.
- if {[info exists cacheArray($rowid)]} {
- set list $cacheArray($rowid)
- } else {
- set list [$this nextrow]
- if {[lempty $list]} {
- if {$return} { return }
- set var ""
- return 0
- }
- if {$autocache} { set cacheArray($rowid) $list }
- }
-
- incr rowid
-
- switch -- $type {
- "-list" {
- if {$return} {
- return $list
- } else {
- set var $list
- }
- }
- "-array" {
- if {$return} {
- foreach field $fields elem $list {
- lappend var $field $elem
- }
- return $var
- } else {
- eval lassign_array [list $list] var $fields
- }
- }
- "-keyvalue" {
- foreach field $fields elem $list {
- lappend var -$field $elem
- }
- if {$return} { return $var }
- }
-
- default {
- incr rowid -1
- return -code error \
- "In-valid type: must be -list, -array or -keyvalue"
- }
- }
- return [expr [lempty $list] == 0]
+ set return 1
+ if {![lempty $varName]} {
+ upvar 1 $varName var
+ set return 0
+ }
+
+ catch {unset var}
+
+ set list ""
+ ## If we have a cached result for this row, use it.
+ if {[info exists cacheArray($rowid)]} {
+ set list $cacheArray($rowid)
+ } else {
+ set list [$this nextrow]
+ if {[lempty $list]} {
+ if {$return} { return }
+ set var ""
+ return 0
+ }
+ if {$autocache} { set cacheArray($rowid) $list }
+ }
+
+ incr rowid
+
+ switch -- $type {
+ "-list" {
+ if {$return} {
+ return $list
+ } else {
+ set var $list
+ }
+ }
+ "-array" {
+ if {$return} {
+ foreach field $fields elem $list {
+ lappend var $field $elem
+ }
+ return $var
+ } else {
+ eval lassign_array [list $list] var $fields
+ }
+ }
+ "-keyvalue" {
+ foreach field $fields elem $list {
+ lappend var -$field $elem
+ }
+ if {$return} { return $var }
+ }
+
+ default {
+ incr rowid -1
+ return -code error \
+ "In-valid type: must be -list, -array or -keyvalue"
+ }
+ }
+ return [expr [lempty $list] == 0]
}
method resultid {{string ""}} { return [configure_variable resultid $string] }
@@ -808,17 +808,17 @@ proc handle {interface args} {
method errorinfo {{string ""}} { return [configure_variable errorinfo $string] }
method autocache {{string ""}} { return [configure_variable autocache $string] }
- public variable resultid ""
- public variable fields ""
- public variable rowid 0
- public variable numrows 0
- public variable error 0
- public variable errorcode 0
- public variable errorinfo ""
- public variable autocache 1
+ public variable resultid ""
+ public variable fields ""
+ public variable rowid 0
+ public variable numrows 0
+ public variable error 0
+ public variable errorcode 0
+ public variable errorinfo ""
+ public variable autocache 1
- protected variable cached 0
- protected variable cacheSize 0
+ protected variable cached 0
+ protected variable cacheSize 0
protected variable cacheArray
} ; ## ::itcl::class Result
Modified: tcl/rivet/branches/modular/rivet/packages/dio/dio_Mysql.tcl
URL: http://svn.apache.org/viewvc/tcl/rivet/branches/modular/rivet/packages/dio/dio_Mysql.tcl?rev=1560624&r1=1560623&r2=1560624&view=diff
==============================================================================
--- tcl/rivet/branches/modular/rivet/packages/dio/dio_Mysql.tcl (original)
+++ tcl/rivet/branches/modular/rivet/packages/dio/dio_Mysql.tcl Thu Jan 23 10:40:39 2014
@@ -6,7 +6,7 @@
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
-# http://www.apache.org/licenses/LICENSE-2.0
+# http://www.apache.org/licenses/LICENSE-2.0
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
@@ -20,185 +20,192 @@ package provide dio_Mysql 0.2
namespace eval DIO {
::itcl::class Mysql {
- inherit Database
+ inherit Database
- constructor {args} {eval configure $args} {
- if { [catch {package require Mysqltcl}] \
- && [catch {package require mysqltcl}] \
- && [catch {package require mysql} ] } {
- return -code error "No MySQL Tcl package available"
- }
-
- eval configure $args
-
- if {[lempty $db]} {
- if {[lempty $user]} {
- set user $::env(USER)
- }
- set db $user
- }
- }
-
- destructor {
- close
- }
-
- method open {} {
- set command "mysqlconnect"
-
- if {![lempty $user]} { lappend command -user $user }
- if {![lempty $pass]} { lappend command -password $pass }
- if {![lempty $port]} { lappend command -port $port }
- if {![lempty $host]} { lappend command -host $host }
- if {[catch $command error]} { return -code error $error }
-
- set conn $error
-
- if {![lempty $db]} { mysqluse $conn $db }
- }
-
- method close {} {
- if {![info exists conn]} { return }
- catch {mysqlclose $conn}
- unset conn
- }
+ constructor {args} {eval configure $args} {
+ if { [catch {package require Mysqltcl}] \
+ && [catch {package require mysqltcl}] \
+ && [catch {package require mysql} ] } {
+ return -code error "No MySQL Tcl package available"
+ }
+
+ eval configure $args
+
+ if {[lempty $db]} {
+ if {[lempty $user]} {
+ set user $::env(USER)
+ }
+ set db $user
+ }
+ }
+
+ destructor {
+ close
+ }
+
+ method open {} {
+ set command "mysqlconnect"
+
+ if {![lempty $user]} { lappend command -user $user }
+ if {![lempty $pass]} { lappend command -password $pass }
+ if {![lempty $port]} { lappend command -port $port }
+ if {![lempty $host]} { lappend command -host $host }
+ if {[catch $command error]} { return -code error $error }
+
+ set conn $error
+
+ if {![lempty $db]} { mysqluse $conn $db }
+ }
+
+ method close {} {
+ if {![info exists conn]} { return }
+ catch {mysqlclose $conn}
+ unset conn
+ }
- method exec {req} {
- if {![info exists conn] || ![mysqlping $conn]} { open }
+ method exec {req} {
+ if {![info exists conn] || ![mysqlping $conn]} { open }
- set cmd mysqlexec
+ set cmd mysqlexec
#
-# if {[::string tolower [lindex $req 0]] == "select"} { set cmd mysqlsel }
-# select is a 6 characters word, so let's see if the query is a select
+# if {[::string tolower [lindex $req 0]] == "select"} { set cmd mysqlsel }
+# select is a 6 characters word, so let's see if the query is a select
#
- set q [::string trim $req]
+ set q [::string trim $req]
-# set q [::string tolower $q]
-# set q [::string range $q 0 5]
-# if {[::string match select $q]} { set cmd mysqlsel }
-
- if {[regexp -nocase {^\(*\s*select\s+} $q]} { set cmd mysqlsel }
-
- set errorinfo ""
- if {[catch {$cmd $conn $req} error]} {
- set errorinfo $error
- set obj [result Mysql -error 1 -errorinfo [::list $error]]
- return $obj
- }
- if {[catch {mysqlcol $conn -current name} fields]} { set fields "" }
- set obj [result Mysql -resultid $conn \
- -numrows [::list $error] -fields [::list $fields]]
- return $obj
- }
-
- method lastkey {} {
- if {![info exists conn] || ![mysqlping $conn]} { return }
- return [mysqlinsertid $conn]
- }
-
- method quote {string} {
- if {![catch {mysqlquote $string} result]} { return $result }
- regsub -all {'} $string {\'} string
- return $string
- }
-
- method sql_limit_syntax {limit {offset ""}} {
- if {[lempty $offset]} {
- return " LIMIT $limit"
- }
- return " LIMIT [expr $offset - 1],$limit"
- }
-
- method handle {} {
- if {![info exists conn] || ![mysqlping $conn]} { open }
-
- return $conn
- }
-
- method makeDBFieldValue {table_name field_name val {convert_to {}}} {
- if {[info exists specialFields(${table_name}@${field_name})]} {
- switch $specialFields(${table_name}@${field_name}) {
- DATE {
- set secs [clock scan $val]
- set my_val [clock format $secs -format {%Y-%m-%d}]
- return "DATE_FORMAT('$my_val', '%Y-%m-%d')"
- }
- DATETIME {
- set secs [clock scan $val]
- set my_val [clock format $secs -format {%Y-%m-%d %T}]
- return "DATE_FORMAT('$my_val', '%Y-%m-%d %T')"
- }
- NOW {
- switch $convert_to {
-
- # we try to be coherent with the original purpose of this method whose
- # goal is to provide to the programmer a uniform way to handle timestamps.
- # E.g.: Package session expects this case to return a timestamp in seconds
- # so that differences with timestamps returned by [clock seconds]
- # can be done and session expirations are computed consistently.
- # (Bug #53703)
-
- SECS {
- if {[::string compare $val "now"] == 0} {
-# set secs [clock seconds]
-# set my_val [clock format $secs -format {%Y%m%d%H%M%S}]
-# return $my_val
- return [clock seconds]
- } else {
- return "UNIX_TIMESTAMP($field_name)"
- }
- }
- default {
- if {[::string compare $val, "now"] == 0} {
- set secs [clock seconds]
- } else {
- set secs [clock scan $val]
- }
-
- # this is kind of going back and forth from the same
- # format,
-
- #set my_val [clock format $secs -format {%Y-%m-%d %T}]
- return "FROM_UNIXTIME('$secs')"
- }
- }
- }
- default {
- # no special code for that type!!
- return "'[quote $val]'"
- }
- }
- } else {
- return "'[quote $val]'"
- }
- }
-
- public variable db "" {
- if {[info exists conn] && [mysqlping $conn]} {
- mysqluse $conn $db
- }
- }
+# set q [::string tolower $q]
+# set q [::string range $q 0 5]
+# if {[::string match select $q]} { set cmd mysqlsel }
+
+ if {[regexp -nocase {^\(*\s*select\s+} $q]} { set cmd mysqlsel }
+
+ set errorinfo ""
+ if {[catch {$cmd $conn $req} error]} {
+ set errorinfo $error
+ set obj [result Mysql -error 1 -errorinfo [::list $error]]
+ return $obj
+ }
+ if {[catch {mysqlcol $conn -current name} fields]} { set fields "" }
+ set obj [result Mysql -resultid $conn \
+ -numrows [::list $error] \
+ -fields [::list $fields]]
+ return $obj
+ }
+
+ method lastkey {} {
+ if {![info exists conn] || ![mysqlping $conn]} { return }
+ return [mysqlinsertid $conn]
+ }
+
+ method quote {string} {
+ if {![catch {mysqlquote $string} result]} { return $result }
+ regsub -all {'} $string {\'} string
+ return $string
+ }
+
+ method sql_limit_syntax {limit {offset ""}} {
+ if {[lempty $offset]} {
+ return " LIMIT $limit"
+ }
+ return " LIMIT [expr $offset - 1],$limit"
+ }
+
+ method handle {} {
+ if {![info exists conn] || ![mysqlping $conn]} { open }
+ return $conn
+ }
+
+ method makeDBFieldValue {table_name field_name val {convert_to {}}} {
+
+ if {[info exists specialFields(${table_name}@${field_name})]} {
+ switch $specialFields(${table_name}@${field_name}) {
+ DATE {
+ set secs [clock scan $val]
+ set my_val [clock format $secs -format {%Y-%m-%d}]
+ return "DATE_FORMAT('$my_val','%Y-%m-%d')"
+ }
+ DATETIME {
+ set secs [clock scan $val]
+ set my_val [clock format $secs -format {%Y-%m-%d %T}]
+ return "DATE_FORMAT('$my_val','%Y-%m-%d %T')"
+ }
+ NOW {
+ switch $convert_to {
+
+ # we try to be coherent with the original purpose of this method whose
+ # goal is endow the class with a uniform way to handle timestamps.
+ # E.g.: Package session expects this case to return a timestamp in seconds
+ # so that differences with timestamps returned by [clock seconds]
+ # can be done and session expirations are computed consistently.
+ # (Bug #53703)
+
+ SECS {
+ if {[::string compare $val "now"] == 0} {
+
+# set secs [clock seconds]
+# set my_val [clock format $secs -format {%Y%m%d%H%M%S}]
+# return $my_val
+
+ return [clock seconds]
+
+ } else {
+ return "UNIX_TIMESTAMP($field_name)"
+ }
+ }
+ default {
+
+ if {[::string compare $val, "now"] == 0} {
+ set secs [clock seconds]
+ } else {
+ set secs [clock scan $val]
+ }
+
+ # this is kind of going back and forth from the same
+ # format,
+
+ #set my_val [clock format $secs -format {%Y-%m-%d %T}]
+ return "FROM_UNIXTIME('$secs')"
+ }
+ }
+ }
+ default {
+ # no special code for that type!!
+ return "'[quote $val]'"
+ }
+ }
+
+ } else {
+ return "'[quote $val]'"
+ }
+
+ }
+
+ public variable db "" {
+ if {[info exists conn] && [mysqlping $conn]} {
+ mysqluse $conn $db
+ }
+ }
- public variable interface "Mysql"
- private variable conn
+ public variable interface "Mysql"
+ private variable conn
} ; ## ::itcl::class Mysql
::itcl::class MysqlResult {
- inherit Result
+ inherit Result
- constructor {args} {
- eval configure $args
- }
+ constructor {args} {
+ eval configure $args
+ }
- destructor {
+ destructor {
- }
+ }
- method nextrow {} {
- return [mysqlnext $resultid]
- }
-
+ method nextrow {} {
+ return [mysqlnext $resultid]
+ }
+
} ; ## ::itcl::class MysqlResult
}
Modified: tcl/rivet/branches/modular/rivet/packages/dio/dio_Postgresql.tcl
URL: http://svn.apache.org/viewvc/tcl/rivet/branches/modular/rivet/packages/dio/dio_Postgresql.tcl?rev=1560624&r1=1560623&r2=1560624&view=diff
==============================================================================
--- tcl/rivet/branches/modular/rivet/packages/dio/dio_Postgresql.tcl (original)
+++ tcl/rivet/branches/modular/rivet/packages/dio/dio_Postgresql.tcl Thu Jan 23 10:40:39 2014
@@ -6,7 +6,7 @@
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
-# http://www.apache.org/licenses/LICENSE-2.0
+# http://www.apache.org/licenses/LICENSE-2.0
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
@@ -20,157 +20,156 @@ package provide dio_Postgresql 0.1
namespace eval DIO {
::itcl::class Postgresql {
- inherit Database
+ inherit Database
- constructor {args} {eval configure $args} {
- package require Pgtcl
- set_conn_defaults
- eval configure $args
- }
-
- destructor {
- close
- }
-
- ## Setup our variables with the default conninfo from Postgres.
- private method set_conn_defaults {} {
- foreach list [pg_conndefaults] {
- set var [lindex $list 0]
- set val [lindex $list end]
- switch -- $var {
- "dbname" { set db $val }
- default { set $var $val }
- }
- }
- }
-
- method open {} {
- set command "pg_connect"
-
- set info ""
- if {![lempty $user]} { append info " user=$user" }
- if {![lempty $pass]} { append info " password=$pass" }
- if {![lempty $host]} { append info " host=$host" }
- if {![lempty $port]} { append info " port=$port" }
- if {![lempty $db]} { append info " dbname=$db" }
-
- if {![lempty $info]} { append command " -conninfo [::list $info]" }
-
- if {[catch $command error]} { return -code error $error }
-
- set conn $error
- }
-
- method close {} {
- if {![info exists conn]} { return }
- pg_disconnect $conn
- unset conn
- }
-
- method exec {req} {
- if {![info exists conn]} { open }
-
- set command pg_exec
- if {[catch {$command $conn $req} result]} { return -code error $result }
-
- set errorinfo ""
- set obj [result Postgresql -resultid $result]
- if {[$obj error]} { set errorinfo [$obj errorinfo] }
- return $obj
- }
-
- method nextkey {} {
- return [$this string "select nextval( '$sequence' )"]
- }
-
- method lastkey {} {
- return [$this string "select last_value from $sequence"]
- }
-
- method sql_limit_syntax {limit {offset ""}} {
- set sql " LIMIT $limit"
- if {![lempty $offset]} { append sql " OFFSET $offset" }
- return $sql
- }
-
- #
- # handle - return the internal database handle, in the postgres
- # case, the postgres connection handle
- #
- method handle {} {
- if {![info exists conn]} { open }
- return $conn
- }
-
-
- method makeDBFieldValue {table_name field_name val {convert_to {}}} {
- if {[info exists specialFields(${table_name}@${field_name})]} {
- switch $specialFields(${table_name}@${field_name}) {
- DATE {
- set secs [clock scan $val]
- set my_val [clock format $secs -format {%Y-%m-%d}]
- return "'$my_val'"
- }
- DATETIME {
- set secs [clock scan $val]
- set my_val [clock format $secs -format {%Y-%m-%d %T}]
- return "'$my_val'"
- }
- NOW {
- switch $convert_to {
+ constructor {args} {eval configure $args} {
+ package require Pgtcl
+ set_conn_defaults
+ eval configure $args
+ }
+
+ destructor {
+ close
+ }
+
+ ## Setup our variables with the default conninfo from Postgres.
+ private method set_conn_defaults {} {
+ foreach list [pg_conndefaults] {
+ set var [lindex $list 0]
+ set val [lindex $list end]
+ switch -- $var {
+ "dbname" { set db $val }
+ default { set $var $val }
+ }
+ }
+ }
+
+ method open {} {
+ set command "pg_connect"
+
+ set info ""
+ if {![lempty $user]} { append info " user=$user" }
+ if {![lempty $pass]} { append info " password=$pass" }
+ if {![lempty $host]} { append info " host=$host" }
+ if {![lempty $port]} { append info " port=$port" }
+ if {![lempty $db]} { append info " dbname=$db" }
+
+ if {![lempty $info]} { append command " -conninfo [::list $info]" }
+
+ if {[catch $command error]} { return -code error $error }
+
+ set conn $error
+ }
+
+ method close {} {
+ if {![info exists conn]} { return }
+ pg_disconnect $conn
+ unset conn
+ }
+
+ method exec {req} {
+ if {![info exists conn]} { open }
+
+ set command pg_exec
+ if {[catch {$command $conn $req} result]} { return -code error $result }
+
+ set errorinfo ""
+ set obj [result Postgresql -resultid $result]
+ if {[$obj error]} { set errorinfo [$obj errorinfo] }
+ return $obj
+ }
+
+ method nextkey {} {
+ return [$this string "select nextval( '$sequence' )"]
+ }
+
+ method lastkey {} {
+ return [$this string "select last_value from $sequence"]
+ }
+
+ method sql_limit_syntax {limit {offset ""}} {
+ set sql " LIMIT $limit"
+ if {![lempty $offset]} { append sql " OFFSET $offset" }
+ return $sql
+ }
+
+ #
+ # handle - return the internal database handle, in the postgres
+ # case, the postgres connection handle
+ #
+ method handle {} {
+ if {![info exists conn]} { open }
+ return $conn
+ }
+
+ method makeDBFieldValue {table_name field_name val {convert_to {}}} {
+ if {[info exists specialFields(${table_name}@${field_name})]} {
+ switch $specialFields(${table_name}@${field_name}) {
+ DATE {
+ set secs [clock scan $val]
+ set my_val [clock format $secs -format {%Y-%m-%d}]
+ return "'$my_val'"
+ }
+ DATETIME {
+ set secs [clock scan $val]
+ set my_val [clock format $secs -format {%Y-%m-%d %T}]
+ return "'$my_val'"
+ }
+ NOW {
+ switch $convert_to {
- # we try to be coherent with the original purpose of this method whose
- # goal is to provide to the programmer a uniform way to handle timestamps.
- # E.g.: Package session expects this case to return a timestamp in seconds
- # so that differences with timestamps returned by [clock seconds]
- # can be done and session expirations are computed consistently.
- # (Bug #53703)
-
- SECS {
- if {[::string compare $val "now"] == 0} {
-# set secs [clock seconds]
-# set my_val [clock format $secs -format {%Y%m%d%H%M%S}]
-# return $my_val
- return [clock seconds]
- } else {
- return "extract(epoch from $field_name)"
- }
+ # we try to be coherent with the original purpose of this method whose
+ # goal is to provide to the programmer a uniform way to handle timestamps.
+ # E.g.: Package session expects this case to return a timestamp in seconds
+ # so that differences with timestamps returned by [clock seconds]
+ # can be done and session expirations are computed consistently.
+ # (Bug #53703)
+
+ SECS {
+ if {[::string compare $val "now"] == 0} {
+# set secs [clock seconds]
+# set my_val [clock format $secs -format {%Y%m%d%H%M%S}]
+# return $my_val
+ return [clock seconds]
+ } else {
+ return "extract(epoch from $field_name)"
+ }
+ }
+ default {
+ if {[::string compare $val, "now"] == 0} {
+ set secs [clock seconds]
+ } else {
+ set secs [clock scan $val]
}
- default {
- if {[::string compare $val, "now"] == 0} {
- set secs [clock seconds]
- } else {
- set secs [clock scan $val]
- }
- # this is kind of going back and forth from the same
- # format,
+ # this is kind of going back and forth from the same
+ # format,
- return "'[clock format $secs -format {%Y-%m-%d %T}]'"
- }
+ return "'[clock format $secs -format {%Y-%m-%d %T}]'"
}
}
- default {
- # no special code for that type!!
- return "'[quote $val]'"
- }
}
- } else {
+ default {
+ # no special code for that type!!
return "'[quote $val]'"
+ }
}
- }
-
+ } else {
+ return "'[quote $val]'"
+ }
+ }
+
+
+ ## If they change DBs, we need to close the connection and re-open it.
+ public variable db "" {
+ if {[info exists conn]} {
+ close
+ open
+ }
+ }
- ## If they change DBs, we need to close the connection and re-open it.
- public variable db "" {
- if {[info exists conn]} {
- close
- open
- }
- }
-
- public variable interface "Postgresql"
- private variable conn
+ public variable interface "Postgresql"
+ private variable conn
} ; ## ::itcl::class Postgresql
@@ -179,49 +178,49 @@ namespace eval DIO {
#
#
::itcl::class PostgresqlResult {
- inherit Result
+ inherit Result
+
+ constructor {args} {
+ eval configure $args
+
+ if {[lempty $resultid]} {
+ return -code error "No resultid specified while creating result"
+ }
+
+ set numrows [pg_result $resultid -numTuples]
+ set fields [pg_result $resultid -attributes]
+ set errorcode [pg_result $resultid -status]
+ set errorinfo [pg_result $resultid -error]
+
+ # if numrows is zero, see if cmdrows returned anything and if it
+ # did, put that in in place of numrows, hiding a postgresql
+ # idiosyncracy from DIO
+ if {$numrows == 0} {
+ set cmdrows [pg_result $resultid -cmdTuples]
+ if {$cmdrows != ""} {
+ set numrows $cmdrows
+ }
+ }
- constructor {args} {
- eval configure $args
+ if {$errorcode != "PGRES_COMMAND_OK" && \
+ $errorcode != "PGRES_TUPLES_OK"} { set error 1 }
- if {[lempty $resultid]} {
- return -code error "No resultid specified while creating result"
- }
-
- set numrows [pg_result $resultid -numTuples]
- set fields [pg_result $resultid -attributes]
- set errorcode [pg_result $resultid -status]
- set errorinfo [pg_result $resultid -error]
-
- # if numrows is zero, see if cmdrows returned anything and if it
- # did, put that in in place of numrows, hiding a postgresql
- # idiosyncracy from DIO
- if {$numrows == 0} {
- set cmdrows [pg_result $resultid -cmdTuples]
- if {$cmdrows != ""} {
- set numrows $cmdrows
- }
- }
-
- if {$errorcode != "PGRES_COMMAND_OK" \
- && $errorcode != "PGRES_TUPLES_OK"} { set error 1 }
-
- ## Reconfigure incase we want to overset the default values.
- eval configure $args
- }
-
- destructor {
- pg_result $resultid -clear
- }
-
- method clear {} {
- pg_result $resultid -clear
- }
-
- method nextrow {} {
- if {$rowid >= $numrows} { return }
- return [pg_result $resultid -getTuple $rowid]
- }
+ ## Reconfigure incase we want to overset the default values.
+ eval configure $args
+ }
+
+ destructor {
+ pg_result $resultid -clear
+ }
+
+ method clear {} {
+ pg_result $resultid -clear
+ }
+
+ method nextrow {} {
+ if {$rowid >= $numrows} { return }
+ return [pg_result $resultid -getTuple $rowid]
+ }
} ; ## ::itcl::class PostgresqlResult
Modified: tcl/rivet/branches/modular/rivet/packages/dio/pkgIndex.tcl
URL: http://svn.apache.org/viewvc/tcl/rivet/branches/modular/rivet/packages/dio/pkgIndex.tcl?rev=1560624&r1=1560623&r2=1560624&view=diff
==============================================================================
--- tcl/rivet/branches/modular/rivet/packages/dio/pkgIndex.tcl (original)
+++ tcl/rivet/branches/modular/rivet/packages/dio/pkgIndex.tcl Thu Jan 23 10:40:39 2014
@@ -1,6 +1,17 @@
+# Tcl package index file, version 1.1
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script. It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands. When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
package ifneeded DIO 1.0 [list source [file join $dir dio.tcl]]
package ifneeded DIODisplay 1.0 [list source [file join $dir diodisplay.tcl]]
package ifneeded dio_Mysql 0.2 [list source [file join $dir dio_Mysql.tcl]]
+package ifneeded dio_Oracle 0.1 [list source [file join $dir dio_Oracle.tcl]]
package ifneeded dio_Postgresql 0.1 [list source [file join $dir dio_Postgresql.tcl]]
package ifneeded dio_Sqlite 0.1 [list source [file join $dir dio_Sqlite.tcl]]
-package ifneeded dio_Oracle 0.2 [list source [file join $dir dio_Oracle.tcl]]
+package ifneeded dio_Tdbc 0.1 [list source [file join $dir dio_Tdbc.tcl]]
Modified: tcl/rivet/branches/modular/rivet/rivet-tcl/tclIndex
URL: http://svn.apache.org/viewvc/tcl/rivet/branches/modular/rivet/rivet-tcl/tclIndex?rev=1560624&r1=1560623&r2=1560624&view=diff
==============================================================================
--- tcl/rivet/branches/modular/rivet/rivet-tcl/tclIndex (original)
+++ tcl/rivet/branches/modular/rivet/rivet-tcl/tclIndex Thu Jan 23 10:40:39 2014
@@ -27,3 +27,4 @@ set auto_index(::rivet::parray_table) [l
set auto_index(::rivet::load_cookies) [list source [file join $dir load_cookies.tcl]]
set auto_index(::rivet::http_accept) [list source [file join $dir http_accept.tcl]]
set auto_index(::rivet::xml) [list source [file join $dir xml.tcl]]
+set auto_index(::rivet::lassign_array) [list source [file join $dir lassign_array.tcl]]
Modified: tcl/rivet/branches/modular/src/apache-2/mod_rivet.c
URL: http://svn.apache.org/viewvc/tcl/rivet/branches/modular/src/apache-2/mod_rivet.c?rev=1560624&r1=1560623&r2=1560624&view=diff
==============================================================================
--- tcl/rivet/branches/modular/src/apache-2/mod_rivet.c (original)
+++ tcl/rivet/branches/modular/src/apache-2/mod_rivet.c Thu Jan 23 10:40:39 2014
@@ -75,8 +75,8 @@ static server_rec *rivet_panic_server_
/* rivet or tcl file */
#define CTYPE_NOT_HANDLED 0
-#define RIVET_FILE 1
-#define TCL_FILE 2
+#define RIVET_TEMPLATE 1
+#define RIVET_TCLFILE 2
/* rivet return codes */
#define RIVET_OK 0
@@ -84,14 +84,27 @@ static server_rec *rivet_panic_server_
TCL_DECLARE_MUTEX(sendMutex);
-#define RIVET_FILE_CTYPE "application/x-httpd-rivet"
-#define TCL_FILE_CTYPE "application/x-rivet-tcl"
+#define RIVET_TEMPLATE_CTYPE "application/x-httpd-rivet"
+#define RIVET_TCLFILE_CTYPE "application/x-rivet-tcl"
static Tcl_Interp* Rivet_CreateTclInterp (server_rec* s);
static void Rivet_CreateCache (server_rec *s, apr_pool_t *p);
-
-/* This snippet of code came from the mod_ruby project, which is under a BSD license. */
+/*
+ * -- Rivet_chdir_file (const char* filename)
+ *
+ * Determines the directory name from the filename argument
+ * and sets it as current working directory
+ *
+ * Argument:
+ *
+ * const char* filename: file name to be used for determining
+ * the current directory (URI style path)
+ * the directory name is everything comes
+ * before the last '/' (slash) character
+ *
+ * This snippet of code came from the mod_ruby project, which is under a BSD license.
+ */
static int Rivet_chdir_file (const char *file)
{
@@ -118,8 +131,8 @@ static int Rivet_chdir_file (const char
* Utility function internally used to determine which type
* of file (whether rvt template or plain Tcl script) we are
* dealing with. In order to speed up multiple tests the
- * the test returns an integer (RIVET_FILE) for rvt templates
- * or TCL_FILE for Tcl scripts
+ * the test returns an integer (RIVET_TEMPLATE) for rvt templates
+ * or RIVET_TCLFILE for Tcl scripts
*
* Argument:
*
@@ -141,10 +154,10 @@ Rivet_CheckType (request_rec *req)
int ctype = CTYPE_NOT_HANDLED;
if ( req->content_type != NULL ) {
- if( STRNEQU( req->content_type, RIVET_FILE_CTYPE) ) {
- ctype = RIVET_FILE;
- } else if( STRNEQU( req->content_type, TCL_FILE_CTYPE) ) {
- ctype = TCL_FILE;
+ if( STRNEQU( req->content_type, RIVET_TEMPLATE_CTYPE) ) {
+ ctype = RIVET_TEMPLATE;
+ } else if( STRNEQU( req->content_type, RIVET_TCLFILE_CTYPE) ) {
+ ctype = RIVET_TCLFILE;
}
}
return ctype;
@@ -495,11 +508,13 @@ Rivet_ParseExecFile(TclWebRequest *req,
* file (files included through the 'parse' command) is treated as a template.
*/
- if (!toplevel || (Rivet_CheckType(req->req) == RIVET_FILE))
+ if (!toplevel || (Rivet_CheckType(req->req) == RIVET_TEMPLATE))
{
/* toplevel == 0 means we are being called from the parse
* command, which only works on Rivet .rvt files. */
+
result = Rivet_GetRivetFile(filename, toplevel, outbuf, interp);
+
} else {
/* It's a plain Tcl file */
result = Rivet_GetTclFile(filename, outbuf, interp);
@@ -511,10 +526,8 @@ Rivet_ParseExecFile(TclWebRequest *req,
return result;
}
- if (toplevel) {
- if (rsc->rivet_after_script) {
- Tcl_AppendObjToObj(outbuf,rsc->rivet_after_script);
- }
+ if (toplevel && rsc->rivet_after_script) {
+ Tcl_AppendObjToObj(outbuf,rsc->rivet_after_script);
}
if (*(rsc->cache_size)) {
@@ -1973,8 +1986,8 @@ Rivet_SendContent(request_rec *r)
{
int content_type_len = strlen(r->content_type);
- if (((ctype==RIVET_FILE) && (content_type_len > strlen(RIVET_FILE_CTYPE))) || \
- ((ctype==TCL_FILE) && (content_type_len > strlen(TCL_FILE_CTYPE)))) {
+ if (((ctype==RIVET_TEMPLATE) && (content_type_len > strlen(RIVET_TEMPLATE_CTYPE))) || \
+ ((ctype==RIVET_TCLFILE) && (content_type_len > strlen(RIVET_TCLFILE_CTYPE)))) {
char* charset;
Modified: tcl/rivet/branches/modular/src/request/apache_request.c
URL: http://svn.apache.org/viewvc/tcl/rivet/branches/modular/src/request/apache_request.c?rev=1560624&r1=1560623&r2=1560624&view=diff
==============================================================================
--- tcl/rivet/branches/modular/src/request/apache_request.c (original)
+++ tcl/rivet/branches/modular/src/request/apache_request.c Thu Jan 23 10:40:39 2014
@@ -381,7 +381,9 @@ int ApacheRequest___parse(ApacheRequest
if ((r->method_number == M_POST) && ct && strncaseEQ(ct, MULTIPART_ENCTYPE, MULTIPART_ENCTYPE_LENGTH))
{
- ap_log_rerror(REQ_INFO, "content-type: `%s'", ct);
+ //
+ //ap_log_rerror(REQ_INFO, "content-type: `%s'", ct);
+ //
result = ApacheRequest_parse_multipart(req,ct);
}
else
---------------------------------------------------------------------
To unsubscribe, e-mail: site-cvs-unsubscribe@tcl.apache.org
For additional commands, e-mail: site-cvs-help@tcl.apache.org