rivet-2.3.5/doc/xml/calendar.xml 000644 001750 001750 00000031303 11752325411 016157 0 ustar 00mxm mxm 000000 000000 Calendar PackageIntroduction
The package is based on the Calendar class, a class capable
of printing an ascii calendar table that closely resembles the output
of the typical Unix cal command. The internal
code is written entirely in Tcl, therefore doesn't rely on the
existance of cal on the system.
XmlCalendar inherits the basic methods and adds XML tagging to the
table. XmlCalendar prints an XML calendar table whose header,
weekdays banner and days rows tags are configurable.
Also specific days or specific weeks can be given arbitrary attributes.
Calendar core methods are based on the
cal procedure
written by Richard Suchenwirth and published on the
Tcl Wiki
The Calendar package uses Tcl dict command to manage markup
information. Hence either Tcl8.5 or Tcl8.4 with
package dict are required.
CalendarUtility class the builds and prints a calendar tableCalendarcalendar_nameCalendar object subcommands
The main public command for a calendar object is
emit that returns a calendar table
calendar_obj emit
calendar_obj emitmonthyear
calendar_obj emitmonth | year
The method 'emit' if invoked without arguments returns an
ASCII formatted calendar of the current month
set cal [Calendar #auto]
set current_month [$cal emit]
puts $current_month
Jun 2010
Su Mo Tu We Th Fr Sa
1 2 3 4 5
6 7 8 9 10 11 12
13 14 15 16 17 18 19
20 21 22 23 24 25 26
27 28 29 30
The method emit when invoked with a single argument
takes it as an year number and prints the whole calendar of
that year. When invoked with 2 arguments takes the first as a month, either
expressed in its shortened form ('Jan','Feb',...) or as a number in the
range 1-12. The second argument is a year number.
XmlCalendarPrints XML formatted calendar tablesXmlCalendarcalendar_name-option1 option_list-option2 option_list...
An XmlCalendar object is created and returned. XmlCalendar objects
print XML formatted calendar tables. The markup can be customized
using the configuration options.
Configuration options accept odd-length lists as values. An option_list has the following
structure
tag_name
The first element of an option list is a tag name, the remaining terms are therefore
an even-length sublist which is interpreted as a sequence of attribute-value pairs that
will in turn become attributes of the tag.
Methods
cal_obj emit
cal_obj emitmonthyear
cal_obj emitmonth | year
The method 'emit' if invoked without arguments returns an
XML calendar table of the current month
Options-container tag_name
Assigns an options list to the XML element that
will hold the whole table.
The default tag for the container is 'calendar', with no attributes.
-header tag_name
Assigns tag name and attributes to the XML header element (default: calheader)
-body tag_name
Assigns tag name and attributes to the XML body element of the table (default: calbody)
-banner tag_name
Assigns tag name and attributes to the XML banner element of the table (default: monthyear)
The header of a calendar table is made of a banner, showing the Month and Year number, and
of a weekdays bar.
-foot tag_name
Assigns tag name and attributes to the XML foot element
of the table (default: calfoot).
This option was added for completeness, but it's not implemented yet
-banner_month tag_name
Tag name and attributes for the XML element holding the
month name (default:month)
-banner_year tag_name
Tag name and attributes for the XML element holding the
month name (default: year)
-weekdays tag_name
Tag name and attributes for the XML element holding the
weekday header (default: weekdays)
-weekdays_cell tag_name
Tag name and attributes for the XML element holding the
each single weekday (default: wkdays)
-days_row tag_name
Tag name and attributes for the XML element holding the
each row of the calendar table (default: week)
-days_cell tag_name
Tag name and attributes for the XML element representing
a cell in the calendar table (default: day)
-cell_function
If set this option is the name of a procedure that gets
called for every day of the month. The procedure must
accept 4 argument representing day, month, year and weekday
and must return an odd-length list interpreted in the same
way as options lists.
-current_day
This option works as a simple method for pointing out
a specific day of the month. If set with a day number
that day will get the class attribute automatically
set as "current"
-current_weekday
This option works as a simple method for pointing out
a specific weekday of the month. If set with a weekday
index (0: Sunday, 6: Saturday) the corresponding cell in
the weekdays header will get the class attribute automatically
set as "current_wkday"
HtmlCalendarConcrete class derived from XmlCalendarHtmlCalendarcalendar_name-option1 option_list-option2 option_list...
Concrete XmlCalendar class for printing html calendar tables. The markup of the class
is xhtml compliant and prints a code fragment for inclusion in a webpage.
The following is the class definition.
::itcl::class HtmlCalendar {
inherit XmlCalendar
constructor {args} {XmlCalendar::constructor $args} {
$this configure -container table \
-header thead \
-body tbody \
-banner tr \
-banner_month {th colspan 3 style "text-align: right;"} \
-banner_year {th colspan 4 style "text-align: left;"} \
-weekdays tr \
-weekday_cell th \
-days_row tr \
-days_cell td
}
}
A sample output from HtmlCalendar (with some styling)
rivet-2.3.5/doc/examples-sgml/vars.html 000644 001750 001750 00000002130 11562073576 017512 0 ustar 00mxm mxm 000000 000000 <form action="vars.rvt">
<table>
<tbody>
<tr>
<td><b>Title:</b></td>
<td><input name="title" /></td>
</tr>
<tr>
<td><b>Salary:</b></td>
<td><input name="salary" /></td>
</tr>
<tr>
<td><b>Boss:</b></td>
<td><input name="boss" /></td></tr>
<tr>
<td><b>Skills:</b></td>
<td>
<select name="skills" multiple="multiple">
<option>C</option>
<option>Java</option>
<option>Tcl</option>
<option>Perl</option>
</select>
</td>
</tr>
<tr>
<td><input type="submit" /></td>
</tr>
</tbody>
</table>
</form>
rivet-2.3.5/rivet/packages/dio/dio.tcl 000644 001750 001750 00000064271 12254346343 017277 0 ustar 00mxm mxm 000000 000000 # dio.tcl -- implements a database abstraction layer.
# Copyright 2002-2004 The Apache Software Foundation
# Licensed under the Apache License, Version 2.0 (the "License");
# 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
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
# $Id: dio.tcl 1552005 2013-12-18 16:27:15Z mxmanghi $
catch {package require Tclx}
package require Itcl
##set auto_path [linsert $auto_path 0 [file dirname [info script]]]
namespace eval ::DIO {
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]
}
uplevel \#0 package require dio_$interface
return [uplevel \#0 ::DIO::$interface $obj $args]
}
##
# DATABASE CLASS
##
::itcl::class Database {
constructor {args} {
eval configure $args
}
destructor {
close
}
#
# result - generate a new DIO result object for the specified database
# interface, with key-value pairs that get configured into the new
# result object.
#
protected method result {interface args} {
return [eval uplevel \#0 ::DIO::${interface}Result \#auto $args]
}
#
# quote - given a string, return the same string with any single
# quote characters preceded by a backslash
#
method quote {string} {
regsub -all {'} $string {\'} string
return $string
}
#
# build_select_query - build a select query based on given arguments,
# which can include a table name, a select statement, switches to
# turn on boolean AND or OR processing, and possibly
# some key-value pairs that cause the where clause to be
# generated accordingly
#
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"
}
#
# build_insert_query -- given an array name, a list of fields, and
# possibly a table name, return a SQL insert statement inserting
# into the named table (or the object's table variable, if none
# is specified) for all of the fields specified, with their values
# coming from the array
#
protected method build_insert_query {arrayName fields {myTable ""}} {
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 {,}])"
}
#
# build_update_query -- given an array name, a list of fields, and
# possibly a table name, return a SQL update statement updating
# the named table (or using object's table variable, if none
# is named) for all of the fields specified, with their values
# coming from the array
#
# note that after use a where clause still neds to be added or
# 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 {,}]"
}
#
# lassign_array - given a list, an array name, and a variable number
# of arguments consisting of variable names, assign each element in
# the list, in turn, to elements corresponding to the variable
# 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
}
}
#
# configure_variable - given a variable name and a string, if the
# string is empty return the variable name, otherwise set the
# variable to the string.
#
protected method configure_variable {varName string} {
if {[lempty $string]} { return [cget -$varName] }
configure -$varName $string
}
#
# build_where_key_clause - given a list of one or more key fields and
# a corresponding list of one or more key values, construct a
# SQL where clause that boolean ANDs all of the key-value pairs
# 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
}
##
## makekey -- Given an array containing a key-value pairs and
# an optional list of key fields (we use the object's keyfield
# if none is specified)...
#
# if we're doing auto keys, create and return a new key,
# otherwise if it's a single key, just return its value
# from the array, else if it's multiple keys, return all their
# 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
}
method destroy {} {
::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
}
#
# list - execute a request and return a list of the first element of each
# row returned.
#
method list {req} {
set res [exec $req]
set list ""
$res forall -list line {
lappend list [lindex $line 0]
}
$res destroy
return $list
}
#
# array - execute a request and setup an array containing elements
# with the field names as the keys and the first row results as
# the values
#
method array {req arrayName} {
upvar 1 $arrayName $arrayName
set res [exec $req]
set ret [$res next -array $arrayName]
$res destroy
return $ret
}
#
# forall - execute a SQL select and iteratively fill the named array
# with elements named with the matching field names, containing the
# matching values, executing the specified code body for each, in turn.
#
method forall {req arrayName body} {
upvar 1 $arrayName $arrayName
set res [exec $req]
$res forall -array $arrayName {
uplevel 1 $body
}
if {[$res error]} {
set errinf [$res errorinfo]
$res destroy
return -code error "Got '$errinf' executing '$req'"
}
set ret [$res numrows]
$res destroy
return $ret
}
#
# table_check - internal method to populate the data array with
# a -table element containing the table name, a -keyfield element
# containing the key field or list of key fields, and a list of
# key-value pairs to get set into the data table.
#
# afterwards, it's an error if -table or -keyfield hasn't somehow been
# 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"
}
set $keyVar $data(-keyfield)
}
#
# key_check - given a list of key fields and a list of keys, it's
# an error if there aren't the same number of each, and if it's
# 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."
}
}
#
# fetch - given a key (or list of keys) an array name, and some
# extra key-value arguments like -table and -keyfield, fetch
# 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
return $rows_found
}
#
# store - given an array containing key-value pairs and optional
# arguments like -table and -keyfield, insert or update the
# 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
if {$numrows} {
$this update $arrayName {*}$args
} else {
$this insert $myTable $arrayName
}
return 1
}
#
# update - a pure update, without store's somewhat clumsy
# efforts to see if it needs to be an update rather than
# an insert
#
method update {arrayName args} {
table_check $args
upvar 1 $arrayName $arrayName $arrayName array
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
}
#
# update_with_explicit_key - an update where the key is specified
# as an argument to the proc rather than being dug out of the array
#
# this is a kludge until we come up with a better way to
# solve the problem of updating a row where we actually
# 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
}
#
# insert - a pure insert, without store's somewhat clumsy
# efforts to see if it needs to be an update rather than
# 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]
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'"
}
set n_deleted_rows [$res numrows]
$res destroy
return $n_deleted_rows
}
#
# 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
return $keys
}
#
# search - construct and execute a SQL select statement using
# build_select_query style and return the result handle.
#
method search {args} {
set req [eval build_select_query $args]
return [exec $req]
}
#
# count - return a count of the specified (or current) table.
#
method count {args} {
# table_check returns an error if either a keyfield or a table were not set.
# In order to count the rows in a table we don't need a keyfield, so we check
# if table_check is returning missing_table and in case we rethrow the error,
# otherwise we continue
if {[catch {table_check $args} e]} {
if {$e != "missing_keyfield"} {
return -code error -errorcode $e "error in table_check ($e)"
}
}
return [string "select count(*) from $myTable"]
}
method makeDBFieldValue {table_name field_name val} {
return "'[quote $val]'"
}
method registerSpecialField {table_name field_name type} {
set specialFields(${table_name}@${field_name}) $type
}
##
## These are methods which should be defined by each individual database
## interface class.
##
method open {args} {}
method close {args} {}
method exec {args} {}
method nextkey {args} {}
method lastkey {args} {}
method now {} {}
##
## Functions to get and set public variables.
##
method interface {{string ""}} { return [configure_variable interface $string] }
method errorinfo {{string ""}} { return [configure_variable errorinfo $string] }
method db {{string ""}} { return [configure_variable db $string] }
method table {{string ""}} { return [configure_variable table $string] }
method keyfield {{string ""}} { return [configure_variable keyfield $string] }
method autokey {{string ""}} { return [configure_variable autokey $string] }
method sequence {{string ""}} { return [configure_variable sequence $string] }
method user {{string ""}} { return [configure_variable user $string] }
method pass {{string ""}} { return [configure_variable pass $string] }
method host {{string ""}} { return [configure_variable host $string] }
method port {{string ""}} { return [configure_variable port $string] }
protected variable specialFields
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"
}
}
} ; ## ::itcl::class Database
#
# DIO Result object
#
::itcl::class Result {
constructor {args} {
eval configure $args
}
destructor { }
method destroy {} {
::itcl::delete object $this
}
#
# configure_variable - given a variable name and a string, if the
# string is empty return the variable name, otherwise set the
# variable to the string.
#
protected method configure_variable {varName string} {
if {[lempty $string]} { return [cget -$varName] }
configure -$varName $string
}
#
# lassign_array - given a list, an array name, and a variable number
# of arguments consisting of variable names, assign each element in
# the list, in turn, to elements corresponding to the variable
# 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
}
}
#
# seek - set the current row ID (our internal row cursor, if you will)
# to the specified row ID
#
method seek {newrowid} {
set rowid $newrowid
}
method cache {{size "all"}} {
set cacheSize $size
if {$size == "all"} { set cacheSize $numrows }
## 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
}
#
# 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
}
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]
}
method resultid {{string ""}} { return [configure_variable resultid $string] }
method fields {{string ""}} { return [configure_variable fields $string] }
method rowid {{string ""}} { return [configure_variable rowid $string] }
method numrows {{string ""}} { return [configure_variable numrows $string] }
method error {{string ""}} { return [configure_variable error $string] }
method errorcode {{string ""}} { return [configure_variable errorcode $string] }
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
protected variable cached 0
protected variable cacheSize 0
protected variable cacheArray
} ; ## ::itcl::class Result
} ; ## namespace eval DIO
package provide DIO 1.0
rivet-2.3.5/doc/html/html_calendar.html 000644 001750 001750 00000007434 13200160530 017510 0 ustar 00mxm mxm 000000 000000
HtmlCalendar
HtmlCalendar
Calendar Package
Name
HtmlCalendar — Concrete class derived from XmlCalendar
Concrete XmlCalendar class for printing html calendar tables. The markup of the class
is xhtml compliant and prints a code fragment for inclusion in a webpage.
The following is the class definition.
}
rivet-2.3.5/rivet/rivet-tcl/parray_table.tcl 000644 001750 001750 00000002532 12215032535 020531 0 ustar 00mxm mxm 000000 000000 ##
## -- parray_table ?pattern? ?html-attibutes?
##
## tablearray prints an array data in HTML table
## This is good when a table is enough to print consistently
## related data.
##
## arrayName - Name of the array to display
## pattern - Wildcard pattern of variables. An empty string
## is tantamout a "*" and prints the whole array
## html-attributes -
## list attribute-value pairs to be given
## to the
"
}
}
rivet-2.3.5/tests/apachetest/apachetest.tcl 000644 001750 001750 00000027112 12764370173 020443 0 ustar 00mxm mxm 000000 000000 # apachetest.tcl -- Tcl-based Apache test suite
# Copyright 2001-2005 The Apache Software Foundation
# Licensed under the Apache License, Version 2.0 (the "License");
# 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
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
# $Id: apachetest.tcl 1759926 2016-09-08 23:12:59Z mxmanghi $
# This test suite provides a means to create configuration files, and
# start apache with user-specified options. All it needs to run is
# the name of the Apache executable, which must, however, be compiled
# with the right options.
set auto_path [linsert $auto_path 0 [file dirname [info script]]]
package require Tclx
package provide apachetest 0.1
#package require http 2.4.5
source [file join [file dirname [info script]] http.tcl]
namespace eval apachetest {
set debug 1
# name of the apache binary, such as /usr/sbin/httpd
variable binname ""
if ![info exists ::httpd_version ] {
puts stderr "Please create httpd_version variable in global namespace"
exit 1
}
variable httpd_version $::httpd_version
# this file should be in the same directory this script is.
variable templatefile [file join [file dirname [info script]] \
template.conf.2.tcl]
}
# apachetest::need_modules --
#
# Tell the test suite which modules we *need* to have. The test
# suite will then check to see if these are either 1) compiled
# into the server or 2) loaded in its configuration file.
#
# Arguments:
# args
#
# Side Effects:
# Sets up the rest of the apachetest tools to find the needed
# modules.
#
# Results:
# None.
proc apachetest::need_modules { modlist } {
variable module_assoc
foreach module_pair $modlist {
set module_assoc([lindex $module_pair 0]) [lindex $module_pair 1]
}
}
# apachetest::connect --
#
# Attempt to open a socket to the web server we are using in our
# tests. Try for 10 seconds before giving up.
#
# Arguments:
# None.
proc apachetest::connect { } {
set starttime [clock seconds]
set diff 0
# We try for 10 seconds.
while { $diff < 10 } {
if { ! [catch {
set sk [socket localhost 8081]
} err]} {
close $sk
return
}
set diff [expr {[clock seconds] - $starttime}]
}
}
# apachetest::start --
#
# Start the web server in the background. After running the
# script specified, stop the server.
#
# Arguments:
# options - command line options to pass to the web server.
# conftext - text to insert into test.conf.
# code - code to run.
#
# Side Effects:
# Runs 'code' in the global namespace.
#
# Results:
# None.
proc apachetest::start { options conftext code } {
variable serverpid 0
variable binname
variable debug
variable httpd_version
set fn [file join [pwd] test.conf]
catch {file delete -force $fn}
set fl [open $fn w]
puts $fl [uplevel [list subst $conftext]]
close $fl
#OpenBSD related workaround, their stock apache tries to chroot by default
#have to add -u to the arguments to prevent this
catch {exec uname} uname_str
if {[string equal $uname_str OpenBSD]} {
set server_args "-u -X -f"
} else {
set server_args [list -X -f]
}
# There has got to be a better way to do this, aside from waiting.
set serverpid [eval exec $binname $server_args \
[file join [pwd] server.conf] $options >& apachelog.txt &]
apachetest::connect
if { $debug > 0 } {
puts "Apache started as PID $serverpid"
}
if { [catch { uplevel $code } err] } { }
# Kill and wait are the only reasons we need TclX.
# apache2 binary started with -X reacts to SIGQUIT and ignores TERM
kill QUIT $serverpid
catch {
set waitres [wait $serverpid]
if { $debug > 0 } {
puts $waitres
}
}
}
# startserver - start the server with 'options'.
proc apachetest::startserver { args } {
variable binname
variable debug
if { [catch {
if { $debug } {
puts "$binname -X -f [file join [pwd] server.conf] [concat $args]"
}
set serverpid [eval exec $binname -X -f "[file join [pwd] server.conf]" [concat $args]]
} err] } {
puts "$err"
}
}
# getbinname - get the name of the apache binary, and check to make
# sure it's ok. The user should supply this parameter.
proc apachetest::getbinname { argv } {
variable binname
set binname [lindex $argv 0]
if { $binname == "" || ! [file executable $binname] } {
error "Please supply the full name and path of the Apache executable on the command line."
}
return $binname
}
# get the modules that are compiled into Apache directly, and return
# the XXX_module name. Check also for the existence of mod_so, which
# we need to load the shared object in the directory above...
proc apachetest::getcompiledin { binname } {
variable module_assoc
set bin [open [list | "$binname" -l] r]
set compiledin [read $bin]
close $bin
set modlist [split $compiledin]
set compiledin [list]
set mod_so_present 0
foreach entry $modlist {
if { [regexp {(.*)\.c$} $entry match modname] } {
if { $modname == "mod_so" } {
set mod_so_present 1
}
if { [info exists module_assoc($modname)] } {
lappend compiledin $module_assoc($modname)
}
}
}
if { $mod_so_present == 0 } {
error "We need mod_so in Apache to run these tests"
}
return $compiledin
}
# find the httpd.conf file
proc apachetest::gethttpdconf { binname } {
set bin [open [list | $binname -V] r]
set options [read $bin]
close $bin
regexp {SERVER_CONFIG_FILE="(.*?)"} "$options" match filename
if { ! [file exists $filename] } {
# see if we can find something by combining HTTP_ROOT + SERVER_CONFIG_FILE
regexp {HTTPD_ROOT="(.*?)"} "$options" match httpdroot
set completename [file join $httpdroot $filename]
if { ! [file exists $completename] } {
error "neither '$filename' or '$completename' exists"
}
return $completename
}
return $filename
}
# apachetest::getallincludes --
#
# Reads the conf file, and returns its text, plus the text in
# all the files that it Includes itself.
#
# Arguments:
# conffile - file to read.
#
# Side Effects:
# None.
#
# Results:
# Text of configuration files.
proc apachetest::getallincludes { conffile } {
if [file exists $conffile] {
set fl [open $conffile r]
set data [read $fl]
close $fl
set newdata {}
foreach line [split $data \n] {
# Look for Include lines.
if { [regexp -line {^[^\#]*Include +(.*)} $line match file] } {
puts "including files from $file"
set file [string trim $file]
# Include directives accept as argument a file, a directory
# or a glob-style file matching pattern. Patterns usually match
# many files, but are not directories, so we have to handle
# all these 3 cases
# we use the glob command to tell whether we are dealing with
# a pure file expression or a matching pattern
set matched_files [glob -nocomplain $file]
set matched_files_n [llength $matched_files]
if {$matched_files_n > 1} {
foreach fl $matched_files {
puts "including $fl"
if [file exists $fl] {
append newdata [getallincludes $fl]
}
}
} elseif {$matched_files_n == 1} {
set file $matched_files
if { [file isdirectory $file] } {
foreach fl [glob -nocomplain [file join $file *]] {
puts "including $fl"
if [file exists $fl] {
append newdata [getallincludes $fl]
}
}
} else {
append newdata [getallincludes $file]
}
}
}
}
append data $newdata
return $data
} else {
return
}
}
# apachetest::getloadmodules --
#
# Get the LoadModule lines for modules that we want to load.
#
# Arguments:
# conffile - the name of the conf file to read.
# needtoget - list of modules that we want to load.
#
# Side Effects:
# None.
#
# Results:
# Returns a string suitable for inclusion in a conf file.
proc apachetest::getloadmodules { conffile needtoget } {
puts "checking $conffile "
set confdata [getallincludes $conffile]
set loadline [list]
regexp -line {^[^#]*(ServerRoot[\s]?[\"]?)([^\"]+)()([\"]?)} $confdata \
match sub1 server_root_path sub2
foreach mod $needtoget {
# Look for LoadModule lines.
puts -nonewline "check conf line for $mod module..."
flush stdout
if { ! [regexp -line "^\[^\#\]*(LoadModule\\s+$mod\\s+.+)\$"\
$confdata match line] } {
error "No LoadModule line for $mod\!"
} else {
puts ok
set raw_path [join [lrange [split $line { }] 2 end]]
#trimming leading whitespaces
set path [string trimleft $raw_path]
if ![string equal [file pathtype $line] "absolute"] {
set absolute_path [file join $server_root_path $path]
lappend loadline "[join [lrange [split $line " "] 0 1]] $absolute_path"
} else {
lappend loadline $line
}
}
}
return [join $loadline "\n"]
}
# Compare what's compiled in with what we need.
proc apachetest::determinemodules { binname } {
variable module_assoc
set compiledin [lsort [getcompiledin $binname]]
set conffile [gethttpdconf $binname]
foreach {n k} [array get module_assoc] {
lappend needed $k
}
set needed [lsort $needed]
set needtoget [list]
foreach mod $needed {
if { [lsearch $compiledin $mod] == -1 } {
lappend needtoget $mod
}
}
if { $needtoget == "" } {
return ""
} else {
return [getloadmodules $conffile $needtoget]
}
}
# apachetest::makeconf --
#
# Creates a config file and writes it to disk.
#
# Arguments:
# outfile - the file to create/write to.
# extra - extra config options to add.
#
# Side Effects:
# Creates a new config file.
#
# Results:
# None.
proc apachetest::makeconf { outfile {extra ""} } {
variable binname
variable templatefile
set CWD [pwd]
#getting uid and gid of user
catch {exec id} raw_string
# username and group no longer needed. User and Group directives removed from
# main conffile template (#Bug 53396)
# set username [lindex [regexp -inline {(uid=)([\d]+)(\()([^\)]+)(\))} $raw_string] 4]
# set group [lindex [regexp -inline {(gid=)([\d]+)(\()([^\)]+)(\))} $raw_string] 4]
# replace with determinemodules
set LOADMODULES [determinemodules $binname]
puts "reading template from $templatefile"
set fl [open [file join . $templatefile] r]
set template [read $fl]
append template $extra
close $fl
puts $template
set out [subst $template]
set of [open $outfile w]
puts $of "$out"
close $of
}
rivet-2.3.5/rivet/rivet-tcl/load_response.tcl 000644 001750 001750 00000001664 11670231317 020731 0 ustar 00mxm mxm 000000 000000 ###
##
## load_response ?arrayName?
## Load any form variables passed to this page into an array.
##
## arrayName - Name of the array to set. Default is 'response'.
##
## $Id: load_response.tcl 1212149 2011-12-08 21:57:35Z mxmanghi $
##
###
namespace eval ::rivet {
proc load_response {{arrayName response}} {
upvar 1 $arrayName response
foreach {var elem} [::rivet::var all] {
if {[info exists response(__$var)]} {
# we have seen var multiple times already, add to the list
lappend response($var) $elem
} elseif {[info exists response($var)]} {
# second occurence of var, convert response(var) list:
set response($var) [list $response($var) $elem]
set response(__$var) ""
} else {
# first time seeing this var
set response($var) $elem
}
}
}
}
rivet-2.3.5/tclconfig/README.txt 000644 001750 001750 00000001454 11220500575 015765 0 ustar 00mxm mxm 000000 000000 These files comprise the basic building blocks for a Tcl Extension
Architecture (TEA) extension. For more information on TEA see:
http://www.tcl.tk/doc/tea/
This package is part of the Tcl project at SourceForge, and latest
sources should be available there:
http://tcl.sourceforge.net/
This package is a freely available open source package. You can do
virtually anything you like with it, such as modifying it, redistributing
it, and selling it either in whole or in part.
CONTENTS
========
The following is a short description of the files you will find in
the sample extension.
README.txt This file
install-sh Program used for copying binaries and script files
to their install locations.
tcl.m4 Collection of Tcl autoconf macros. Included by a package's
aclocal.m4 to define TEA_* macros.
rivet-2.3.5/src/request/apache_request.h 000644 001750 001750 00000010450 12323561775 017752 0 ustar 00mxm mxm 000000 000000 #ifndef _APACHE_REQUEST_H
#define _APACHE_REQUEST_H
#include "httpd.h"
#include "http_config.h"
#include "http_core.h"
#include "http_log.h"
#include "http_main.h"
#include "http_protocol.h"
#include "util_script.h"
#ifdef SFIO
#include "sfio.h"
/* sfio 2000 changed _stdopen to _stdfdopen */
#if SFIO_VERSION >= 20000101L
#define _stdopen _stdfdopen
#endif
extern Sfio_t* _stdopen _ARG_((int, const char*)); /*1999*/
#undef FILE
#define FILE Sfio_t
#undef fwrite
#define fwrite(p,s,n,f) sfwrite((f),(p),(s)*(n))
#undef fseek
#define fseek(f,a,b) sfseek((f),(a),(b))
#undef ap_pfdopen
#define ap_pfdopen(p,q,r) _stdopen((q),(r))
#undef ap_pfclose
#define ap_pfclose(p,q) sfclose(q)
#endif /*SFIO*/
typedef struct ApacheUpload ApacheUpload;
typedef struct _ApacheRequest {
//table *parms;
apr_table_t *parms;
ApacheUpload *upload;
int status;
int parsed;
int post_max;
int disable_uploads;
int (*upload_hook)(void *ptr, char *buf, int len, ApacheUpload *upload);
void *hook_data;
const char* temp_dir;
char* raw_post; /* Raw post data. */
request_rec *r;
int nargs;
} ApacheRequest;
struct ApacheUpload {
ApacheUpload *next;
char *filename;
char *name;
char *tempname;
//table *info;
apr_table_t *info;
apr_file_t *fp;
long size;
ApacheRequest *req;
};
#ifndef strEQ
#define strEQ(s1,s2) (!strcmp((s1),(s2)))
#endif
#ifndef strEQN
#define strEQN(s1,s2,n) (!strncmp((s1),(s2),(n)))
#endif
#ifndef strcaseEQ
#define strcaseEQ(s1,s2) (!strcasecmp((s1),(s2)))
#endif
#ifndef strncaseEQ
#define strncaseEQ(s1,s2,n) (!strncasecmp((s1),(s2),(n)))
#endif
#define DEFAULT_TABLE_NELTS 10
#define DEFAULT_ENCTYPE "application/x-www-form-urlencoded"
#define DEFAULT_ENCTYPE_LENGTH 33
#define MULTIPART_ENCTYPE "multipart/form-data"
#define MULTIPART_ENCTYPE_LENGTH 19
#define TEXT_XML_ENCTYPE "text/xml"
#define TEXT_XML_ENCTYPE_LENGTH 8
#ifdef __cplusplus
extern "C" {
#endif
ApacheRequest* ApacheRequest_new(apr_pool_t *);
ApacheRequest* ApacheRequest_init(ApacheRequest* req, request_rec *r);
/* int ApacheRequest_save_post_data(request_rec *r, int flag);
char *ApacheRequest_fetch_post_data(request_rec *r); */
int ApacheRequest_parse_multipart(ApacheRequest *req,const char* ct);
int ApacheRequest_parse_urlencoded(ApacheRequest *req);
char *ApacheRequest_script_name(ApacheRequest *req);
char *ApacheRequest_script_path(ApacheRequest *req);
const char *ApacheRequest_param(ApacheRequest *req, const char *key);
apr_array_header_t *ApacheRequest_params(ApacheRequest *req, const char *key);
char *ApacheRequest_params_as_string(ApacheRequest *req, const char *key);
int ApacheRequest___parse(ApacheRequest *req);
#define ApacheRequest_parse(req) \
((req)->status = (req)->parsed ? (req)->status : ApacheRequest___parse(req))
apr_table_t *ApacheRequest_query_params(ApacheRequest *req, apr_pool_t *p);
apr_table_t *ApacheRequest_post_params(ApacheRequest *req, apr_pool_t *p);
apr_table_t *ApacheRequest_query_params(ApacheRequest *req, apr_pool_t *p);
apr_table_t *ApacheRequest_post_params(ApacheRequest *req, apr_pool_t *p);
apr_file_t *ApacheRequest_tmpfile(ApacheRequest *req, ApacheUpload *upload);
ApacheUpload *ApacheUpload_new(ApacheRequest *req);
ApacheUpload *ApacheUpload_find(ApacheUpload *upload, char *name);
#define ApacheRequest_upload(req) \
(((req)->parsed || (ApacheRequest_parse(req) == OK)) ? (req)->upload : NULL)
#define ApacheUpload_FILE(upload) ((upload)->fp)
#define ApacheUpload_size(upload) ((upload)->size)
#define ApacheUpload_info(upload, key) \
apr_table_get((upload)->info, (key))
#define ApacheUpload_type(upload) \
ApacheUpload_info((upload), "Content-Type")
#define ApacheRequest_set_post_max(req, max) ((req)->post_max = (max))
#define ApacheRequest_set_temp_dir(req, dir) ((req)->temp_dir = (dir))
#define ApacheRequest_get_raw_post(req) ((req)->raw_post)
char *ApacheUtil_expires(apr_pool_t *p, char *time_str, int type);
#define EXPIRES_HTTP 1
#define EXPIRES_COOKIE 2
char *ApacheRequest_expires(ApacheRequest *req, char *time_str);
#ifdef __cplusplus
}
#endif
#define REQ_ERROR APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, APR_EGENERAL, req->r
#define REQ_INFO APLOG_MARK, APLOG_INFO, APR_EGENERAL, req->r
#ifdef REQDEBUG
#define REQ_DEBUG(a) (a)
#else
#define REQ_DEBUG(a)
#endif
#endif /* _APACHE_REQUEST_H */
rivet-2.3.5/doc/example.tcl 000644 001750 001750 00000001742 07416050616 015233 0 ustar 00mxm mxm 000000 000000 # we have complete access to the interpreter here, so it is best to
# run per-page code in a namespace, just like we do with .rvt pages.
proc getcode { filename } {
set fl [ open $filename r ]
set sourcecode [ read $fl ]
close $fl
regsub -all "&" "$sourcecode" "\\&" sourcecode
regsub -all "<" "$sourcecode" "\\<" sourcecode
regsub -all ">" "$sourcecode" "\\>" sourcecode
return $sourcecode
}
if { ! [ info exists header ] } {
set header {
.tcl example
}
}
if { ! [ info exists footer ] } {
set footer {
}
}
namespace eval request {
hgetvars
puts $header
puts {
This is an example of a .tcl file being processed in Rivet
creates and returns a new Tcl command named form_name.
Options
-method ?post|get?
The http method for sending the form data back to the server.
Possible values are get or post
-name ?form_name?
a name for the form being created: this value becomes the value of the
attribute 'name' in the <form> tag.
-defaults ?default_values?
an array of default values to be assigned to the fields of the form.
Every name in the array is matched with an input field, when
a given field gets added to the form it is initialized with the
value of the corresponding variable in the array.
This option works well in conjuction with the
load_response command of Rivet when default
values come from another form.
-action ?URL?
The URL the data are being sent to. If no ?-action? switch is specified
the data are sent to the form's URL.
Form Object Commands
Form object commands follow the usual syntax of Tcl commands with a ?subcommand? argument playing the
role of a switch among various functionalities of the command. Form objects also need the ?name? parameter
which is to become the value of the 'name' attribute in an input field. This argument is the key that has to be
used by the server-side script to retrieve the input field value.
Options passed to a subcommand are copied into the tag as attribute="value" pairs.
Some subcommands (e.g. form, radiobuttons and checkboxes) treat specific options in a way
that fits the specific organization and function of these fields.
Exceptions to this general syntax are the field and end subcommands.
field is an abstract input field creation method and requires an additional
parameter specifiyng the type of field to create. Every concrete input field generation command
uses this subcommand internally to print the final html.
Print the <form> tag with all its attributes.
This command must be called as first in the form generation
process. The following is a sample of code creating a form named 'formname' whose data will
be sent via the GET method. Initial form fields values will be obtained from array
response
form myform -defaults response -method get -name formname
myform start
myform text text_entry -size 20
myform select option_selected -values {opt1 opt2 opt3 opt4}
myform submit submit -value Search
myform end
The code prints a form that sends a text entry content and the option value
associated with a radiobutton. The URL of the server script is the same that
created the form. Use the ?-url? option to specify a different url.
Options
-method ?post|get?
The method to be used to encode the form data.
Possible values are get or post
-name ?form_name?
a name for the form being generated: this value becomes the value of the
attribute 'name' in the <form> tag.
-defaults ?default_values?
an array of default values to be assigned to the fields of the form.
Every name in the array is matched with an input field, when
a given field gets added to the form it is initialized with the
value of the corresponding variable in the array.
This option works well in conjuction with the
load_response command of Rivet when default values
come from another form.
-action ?URL?
The URL the data will be sent to. If no ?-action? switch is specified
the data are sent to the form's URL.
end
Print the </form> closing tag. This command must
be called last in the form generation process
field ?name? ?type? ?args?
Print a field of the given ?type? and ?name?,
including any default key-value pairs defined for this field
type and optional key-value pairs included with the statement
the radiobutton creates a whole radiobutton group
with the values and labels specified in the argument list.
If no ?-labels? switch is
passed to the subcommand the values are printed as labels of
the radiobutton.
Options
-values ?values_list?
List of values associated with the radiobuttons to be displayed
-labels ?labels_list?
List of labels to be printed with every radiobutton. There must
be a label for every radiobutton
Example:
form myform -defaults response -method get -name formname
myform start
myform text text_entry -size 20
myform radiobuttons fruit -values {big medium small} \
-labels {Watermelon Orange Strawberry} \
-class myradiobclass
myform submit submit -value Search
myform end
if the response array has a variable for the name 'fruit' the corresponding
radiobutton field is automatically checked. The options ?values? and ?labels?
are used internally and don't get into the tag attributes. If a ?labels?
option is not given, labels are assigned using the ?values? list.
The checkbox subcommand emits a checkbox
type input field with the name, label and value attributes set
according to the parameters passed to the subcommand.
The checkboxes is an extended form
of the checkbox subcommand.
checkboxes
prints as many checkboxes as the number of elements in the
?labels_list? argument
Options
-values ?values_list?
List of values associated with the checkboxes to be displayed
-labels ?labels_list?
List of labels to be printed with every checkbox. There must
be a label for every checkbox