source: tcl/00-utils.tcl @ 1

Last change on this file since 1 was 1, checked in by mek, 8 years ago

initial import

File size: 109.1 KB
Line 
1# /tcl/00-ad-utilities.tcl
2#
3# Author: ron@arsdigita.com, February 2000
4#
5# This file provides a variety of utilities (originally written by
6# philg@mit.edu a long time ago) as well as some compatibility
7# functions to handle differences between AOLserver 2.x and
8# AOLserver 3.x.
9#
10# $Id: utilities.txt,v 1.1 2000/05/29 06:59:53 jsc Exp $
11
12proc util_aolserver_2_p {} {
13    if {[string index [ns_info version] 0] == "2"} {
14        return 1
15    } else {
16        return 0
17    }
18}
19
20# Define nsv_set/get/exists for AOLserver 2.0
21
22if [util_aolserver_2_p] {
23    uplevel #0 {
24        proc nsv_set { array key value } {
25            return [ns_var set "$array,$key" $value]
26        }
27       
28        proc nsv_get { array key } {
29            return [ns_var get "$array,$key"]
30        }
31
32        proc nsv_unset {array key } {
33            ns_var unset "$array,$key"
34        }
35       
36        proc nsv_exists { array key } {
37            return [ns_var exists "$array,$key"]
38        }
39
40    }
41}
42
43# Let's define the nsv arrays out here, so we can call nsv_exists
44# on their keys without checking to see if it already exists.
45# we create the array by setting a bogus key.
46
47nsv_set proc_source_file . ""
48
49proc proc_doc {name args doc_string body} {
50    # let's define the procedure first
51    proc $name $args $body
52    nsv_set proc_doc $name $doc_string
53    # generate a log message for multiply defined scripts
54    if {[nsv_exists proc_source_file $name]
55        && [string compare [nsv_get proc_source_file $name] [info script]] != 0} {
56        ns_log Notice "Multiple definition of $name in [nsv_get proc_source_file $name] and [info script]"
57    }
58    nsv_set proc_source_file $name [info script]
59}
60
61proc proc_source_file_full_path {proc_name} {
62    if ![nsv_exists proc_source_file $proc_name] {
63        return ""
64    } else {
65        set tentative_path [nsv_get proc_source_file $proc_name]
66        regsub -all {/\./} $tentative_path {/} result
67        return $result
68    }
69}
70
71proc_doc util_report_library_entry {{extra_message ""}} "Should be called at beginning of private Tcl library files so that it is easy to see in the error log whether or not private Tcl library files contain errors." {
72    set tentative_path [info script]
73    regsub -all {/\./} $tentative_path {/} scrubbed_path
74    if { [string compare $extra_message ""] == 0 } {
75        set message "Loading $scrubbed_path"
76    } else {
77        set message "Loading $scrubbed_path; $extra_message"
78    }
79    ns_log Notice $message
80}
81
82util_report_library_entry
83
84# stuff to process the data that comes
85# back from the users
86
87# if the form looked like
88# <input type=text name=yow> and <input type=text name=bar>
89# then after you run this function you'll have Tcl vars
90# $foo and $bar set to whatever the user typed in the form
91
92# this uses the initially nauseating but ultimately delicious
93# Tcl system function "uplevel" that lets a subroutine bash
94# the environment and local vars of its caller.  It ain't Common Lisp...
95
96proc set_form_variables {{error_if_not_found_p 1}} {
97    if { $error_if_not_found_p == 1} {
98        uplevel { if { [ns_getform] == "" } {
99            ns_returnerror 500 "Missing form data"
100            return
101        }
102       }
103     } else {
104         uplevel { if { [ns_getform] == "" } {
105             # we're not supposed to barf at the user but we want to return
106             # from this subroutine anyway because otherwise we'd get an error
107             return
108         }
109     }
110  }
111
112    # at this point we know that the form is legal
113   
114    uplevel {
115        set form [ns_getform] 
116        set form_size [ns_set size $form]
117        set form_counter_i 0
118        while {$form_counter_i<$form_size} {
119            set [ns_set key $form $form_counter_i] [ns_set value $form $form_counter_i]
120            incr form_counter_i
121        }
122    }
123}
124
125proc DoubleApos {string} {
126    regsub -all ' "$string" '' result
127    return $result
128}
129
130# if the user types "O'Malley" and you try to insert that into an SQL
131# database, you will lose big time because the single quote is magic
132# in SQL and the insert has to look like 'O''Malley'.  This function
133# also trims white space off the ends of the user-typed data.
134
135# if the form looked like
136# <input type=text name=yow> and <input type=text name=bar>
137# then after you run this function you'll have Tcl vars
138# $QQfoo and $QQbar set to whatever the user typed in the form
139# plus an extra single quote in front of the user's single quotes
140# and maybe some missing white space
141
142proc set_form_variables_string_trim_DoubleAposQQ {} {
143    uplevel {
144        set form [ns_getform] 
145        if {$form == ""} {
146            ns_returnerror 500 "Missing form data"
147            return;
148        }
149        set form_size [ns_set size $form]
150        set form_counter_i 0
151        while {$form_counter_i<$form_size} {
152            set QQ[ns_set key $form $form_counter_i] [DoubleApos [string trim [ns_set value $form $form_counter_i]]]
153            incr form_counter_i
154        }
155    }
156}
157
158# this one does both the regular and the QQ
159
160proc set_the_usual_form_variables {{error_if_not_found_p 1}} {
161    if { [ns_getform] == "" } {
162        if $error_if_not_found_p {
163            uplevel { 
164                ns_returnerror 500 "Missing form data"
165                return
166            }
167        } else {
168            return
169        }
170    }
171    uplevel {
172        set form [ns_getform] 
173        set form_size [ns_set size $form]
174        set form_counter_i 0
175        while {$form_counter_i<$form_size} {
176            set [ns_set key $form $form_counter_i] [ns_set value $form $form_counter_i]
177            set QQ[ns_set key $form $form_counter_i] [DoubleApos [string trim [ns_set value $form $form_counter_i]]]
178            incr form_counter_i
179        }
180    }
181}
182
183proc set_form_variables_string_trim_DoubleApos {} {
184    uplevel {
185        set form [ns_getform] 
186        if {$form == ""} {
187            ns_returnerror 500 "Missing form data"
188            return;
189        }
190        set form_size [ns_set size $form]
191        set form_counter_i 0
192        while {$form_counter_i<$form_size} {
193            set [ns_set key $form $form_counter_i] [DoubleApos [string trim [ns_set value $form $form_counter_i]]]
194            incr form_counter_i
195        }
196    }
197}
198
199
200proc set_form_variables_string_trim {} {
201    uplevel {
202        set form [ns_getform] 
203        if {$form == ""} {
204            ns_returnerror 500 "Missing form data"
205            return;
206        }
207        set form_size [ns_set size $form]
208        set form_counter_i 0
209        while {$form_counter_i<$form_size} {
210            set [ns_set key $form $form_counter_i] [string trim [ns_set value $form $form_counter_i]]
211            incr form_counter_i
212        }
213    }
214}
215
216# debugging kludges
217
218proc NsSettoTclString {set_id} {
219    set result ""
220    for {set i 0} {$i<[ns_set size $set_id]} {incr i} {
221        append result "[ns_set key $set_id $i] : [ns_set value $set_id $i]\n"
222    }
223    return $result
224}
225
226proc get_referrer {} {
227    return [ns_set get [ns_conn headers] Referer]
228}
229
230proc post_args_to_query_string {} {
231    set arg_form [ns_getform]
232    if {$arg_form!=""} {
233        set form_counter_i 0
234        while {$form_counter_i<[ns_set size $arg_form]} {
235            append query_return "[ns_set key $arg_form $form_counter_i]=[ns_urlencode [ns_set value $arg_form $form_counter_i]]&"
236            incr form_counter_i
237        }
238        set query_return [string trim $query_return &]
239    }
240}   
241
242proc get_referrer_and_query_string {} {
243    if {[ns_conn method]!="GET"} {
244        set query_return [post_args_to_query_string]
245        return "[get_referrer]?${query_return}"
246    } else {
247        return [get_referrer]
248    }
249}
250
251# a philg hack for getting all the values from a set of checkboxes
252# returns 0 if none are checked, a Tcl list with the values otherwise
253# terence change: specify default return if none checked
254proc_doc util_GetCheckboxValues {form checkbox_name {default_return 0}} "For getting all the boxes from a set of checkboxes in a form.  This procedure takes the complete ns_conn form and returns a list of checkbox values.  It returns 0 if none are found (or some other default return value if specified)." {
255
256    set i 0
257    set size [ns_set size $form]
258
259    while {$i<$size} {
260
261        if { [ns_set key $form $i] == $checkbox_name} {
262
263            # LIST_TO_RETURN will be created if it doesn't exist
264
265            lappend list_to_return [ns_set value $form $i]
266
267        }
268        incr i
269    }
270
271    #if no list, you can specify a default return
272    #default default is 0
273
274    if { [info exists list_to_return] } { return $list_to_return } else {return $default_return}
275
276}
277
278# a legacy name that is deprecated
279proc nmc_GetCheckboxValues {form checkbox_name {default_return 0}} {
280    return [util_GetCheckboxValues $form $checkbox_name $default_return]
281}
282
283
284##
285#  Database-related code
286##
287
288proc nmc_GetNewIDNumber {id_name db} {
289
290    ns_db dml $db "begin transaction;"
291    ns_db dml $db "update id_numbers set $id_name = $id_name + 1;"
292    set id_number [ns_set value\
293            [ns_db 1row $db "select unique $id_name from id_numbers;"] 0]
294    ns_db dml $db "end transaction;"
295
296    return $id_number
297
298}
299
300
301# if you do a
302#   set selection [ns_db 1row $db "select foo,bar from my_table where key=37"]
303#   set_variables_after_query
304# then you will find that the Tcl vars $foo and $bar are set to whatever
305# the database returned.  If you don't like these var names, you can say
306#   set selection [ns_db 1row $db "select count(*) as n_rows from my_table"]
307#   set_variables_after_query
308# and you will find the Tcl var $n_rows set
309
310# You can also use this in a multi-row loop
311#   set selection [ns_db select $db "select *,upper(email) from mailing_list order by upper(email)"]
312#   while { [ns_db getrow $db $selection] } {
313#        set_variables_after_query
314#         ... your code here ...
315#   }
316# then the appropriate vars will be set during your loop
317
318#
319# CAVEAT NERDOR:  you MUST use the variable name "selection"
320#
321
322#
323# we pick long names for the counter and limit vars
324# because we don't want them to conflict with names of
325# database columns or in parent programs
326#
327
328proc set_variables_after_query {} {
329    uplevel {
330            set set_variables_after_query_i 0
331            set set_variables_after_query_limit [ns_set size $selection]
332            while {$set_variables_after_query_i<$set_variables_after_query_limit} {
333                set [ns_set key $selection $set_variables_after_query_i] [ns_set value $selection $set_variables_after_query_i]
334                incr set_variables_after_query_i
335            }
336    }
337}
338
339# as above, but you must use sub_selection
340
341proc set_variables_after_subquery {} {
342    uplevel {
343            set set_variables_after_query_i 0
344            set set_variables_after_query_limit [ns_set size $sub_selection]
345            while {$set_variables_after_query_i<$set_variables_after_query_limit} {
346                set [ns_set key $sub_selection $set_variables_after_query_i] [ns_set value $sub_selection $set_variables_after_query_i]
347                incr set_variables_after_query_i
348            }
349    }
350}
351
352#same as philg's but you can:
353#1. specify the name of the "selection" variable
354#2. append a prefix to all the named variables
355
356proc set_variables_after_query_not_selection {selection_variable {name_prefix ""}} {
357    set set_variables_after_query_i 0
358    set set_variables_after_query_limit [ns_set size $selection_variable]
359    while {$set_variables_after_query_i<$set_variables_after_query_limit} {
360        # NB backslash squarebracket needed since mismatched {} would otherwise mess up value stmt.
361        uplevel "
362        set ${name_prefix}[ns_set key $selection_variable $set_variables_after_query_i] \[ns_set value $selection_variable $set_variables_after_query_i]
363        "
364        incr set_variables_after_query_i
365    }
366}
367
368# takes a query like "select unique short_name from products where product_id = 45"
369# and returns the result (only works when you are after a single row/column
370# intersection)
371
372proc database_to_tcl_string {db sql} {
373
374    set selection [ns_db 1row $db $sql]
375
376    return [ns_set value $selection 0]
377
378}
379
380proc database_to_tcl_string_or_null {db sql {null_value ""}} {
381    set selection [ns_db 0or1row $db $sql]
382    if { $selection != "" } {
383        return [ns_set value $selection 0]
384    } else {
385        # didn't get anything from the database
386        return $null_value
387    }
388}
389
390#for commands like set full_name  ["select first_name, last_name..."]
391
392proc database_cols_to_tcl_string {db sql} {
393    set string_to_return ""     
394    set selection [ns_db 1row $db $sql]
395    set size [ns_set size $selection]
396    set i 0
397    while {$i<$size} {
398        append string_to_return " [ns_set value $selection $i]"
399        incr i
400    }
401    return [string trim $string_to_return]
402}
403
404# takes a query like "select product_id from foobar" and returns all
405# the ids as a Tcl list
406
407proc database_to_tcl_list {db sql} {
408   
409    set selection [ns_db select $db $sql]
410
411    set list_to_return [list]
412
413    while {[ns_db getrow $db $selection]} {
414
415        lappend list_to_return [ns_set value $selection 0]
416
417    }
418
419    return $list_to_return
420
421}
422
423proc database_to_tcl_list_list {db sql} {
424    set selection [ns_db select $db $sql]
425
426    set list_to_return ""
427
428    while {[ns_db getrow $db $selection]} {
429
430        set row_list ""
431        set size [ns_set size $selection]
432        set i 0
433        while {$i<$size} {
434            lappend row_list [ns_set value $selection $i]
435            incr i
436        }
437        lappend list_to_return $row_list
438    }
439
440    return $list_to_return
441}
442
443proc database_1row_to_tcl_list {db sql} {
444
445    if [catch {set selection [ns_db 1row $db $sql]} errmsg] {
446        return ""
447    }
448    set list_to_return ""
449    set size [ns_set size $selection]
450    set counter 0
451
452    while {$counter<$size} {
453        lappend list_to_return [ns_set value $selection $counter]
454        incr counter
455    }
456
457    return $list_to_return
458}
459
460
461proc_doc ad_dbclick_check_dml { db table_name id_column_name generated_id return_url insert_sql } "
462this proc is used for pages using double click protection. table_name is table_name for which we are checking whether the double click occured. id_column_name is the name of the id table column. generated_id is the generated id, which is supposed to have been generated on the previous page. return_url is url to which this procedure will return redirect in the case of successful insertion in the database. insert_sql is the sql insert statement. if data is ok this procedure will insert data into the database in a double click safe manner and will returnredirect to the page specified by return_url. if database insert fails, this procedure will return a sensible error message to the user." {
463    if [catch { 
464        ns_db dml $db $insert_sql
465    } errmsg] {
466        # Oracle choked on the insert
467       
468        # detect double click
469        set selection [ns_db 0or1row $db "
470        select 1
471        from $table_name
472        where $id_column_name='[DoubleApos $generated_id]'"]
473       
474        if { ![empty_string_p $selection] } {
475            # it's a double click, so just redirect the user to the index page
476            ns_returnredirect $return_url
477            return
478        }
479       
480        ns_log Error "[info script] choked. Oracle returned error:  $errmsg"
481
482        ad_return_error "Error in insert" "
483        We were unable to do your insert in the database.
484        Here is the error that was returned:
485        <p>
486        <blockquote>
487        <pre>
488        $errmsg
489        </pre>
490        </blockquote>"
491        return
492    }
493
494    ns_returnredirect $return_url
495    return
496}
497
498proc nmc_IllustraDatetoPrettyDate {sql_date} {
499
500    regexp {(.*)-(.*)-(.*)$} $sql_date match year month day
501
502    set allthemonths {January February March April May June July August September October November December}
503
504    # we have to trim the leading zero because Tcl has such a
505    # brain damaged model of numbers and decided that "09-1"
506    # was "8.0"
507
508    set trimmed_month [string trimleft $month 0]
509    set pretty_month [lindex $allthemonths [expr $trimmed_month - 1]]
510
511    return "$pretty_month $day, $year"
512
513}
514
515proc util_IllustraDatetoPrettyDate {sql_date} {
516
517    regexp {(.*)-(.*)-(.*)$} $sql_date match year month day
518
519    set allthemonths {January February March April May June July August September October November December}
520
521    # we have to trim the leading zero because Tcl has such a
522    # brain damaged model of numbers and decided that "09-1"
523    # was "8.0"
524
525    set trimmed_month [string trimleft $month 0]
526    set pretty_month [lindex $allthemonths [expr $trimmed_month - 1]]
527
528    return "$pretty_month $day, $year"
529
530}
531
532# this is the preferred one to use
533
534proc_doc util_AnsiDatetoPrettyDate {sql_date} "Converts 1998-09-05 to September 5, 1998" {
535    if ![regexp {(.*)-(.*)-(.*)$} $sql_date match year month day] {
536        return ""
537    } else {
538        set allthemonths {January February March April May June July August September October November December}
539
540        # we have to trim the leading zero because Tcl has such a
541        # brain damaged model of numbers and decided that "09-1"
542        # was "8.0"
543
544        set trimmed_month [string trimleft $month 0]
545        set pretty_month [lindex $allthemonths [expr $trimmed_month - 1]]
546
547        set trimmed_day [string trimleft $day 0]
548
549        return "$pretty_month $trimmed_day, $year"
550    }
551}
552
553# from the new-utilities.tcl file
554
555proc remove_nulls_from_ns_set {old_set_id} {
556
557    set new_set_id [ns_set new "no_nulls$old_set_id"]
558
559    for {set i 0} {$i<[ns_set size $old_set_id]} {incr i} {
560        if { [ns_set value $old_set_id $i] != "" } {
561
562            ns_set put $new_set_id [ns_set key $old_set_id $i] [ns_set value $old_set_id $i]
563
564        }
565
566    }
567
568    return $new_set_id
569
570}
571
572proc merge_form_with_ns_set {form set_id} {
573
574    for {set i 0} {$i<[ns_set size $set_id]} {incr i} {
575        set form [ns_formvalueput $form [ns_set key $set_id $i] [ns_set value $set_id $i]]
576    }
577
578    return $form
579
580}
581
582proc merge_form_with_query {form db query} {
583
584    set set_id [ns_db 0or1row $db $query]
585
586    if { $set_id != "" } {
587
588        for {set i 0} {$i<[ns_set size $set_id]} {incr i} {
589            set form [ns_formvalueput $form [ns_set key $set_id $i] [ns_set value $set_id $i]]
590        }
591
592    }
593
594    return $form
595
596}
597
598
599proc bt_mergepiece {htmlpiece values} {
600    # HTMLPIECE is a form usually; VALUES is an ns_set
601
602    # NEW VERSION DONE BY BEN ADIDA (ben@mit.edu)
603    # Last modification (ben@mit.edu) on Jan ?? 1998
604    # added support for dates in the date_entry_widget.
605    #
606    # modification (ben@mit.edu) on Jan 12th, 1998
607    # when the val of an option tag is "", things screwed up
608    # FIXED.
609    #
610    # This used to count the number of vars already introduced
611    # in the form (see remaining num_vars statements), so as
612    # to end early. However, for some unknown reason, this cut off a number
613    # of forms. So now, this processes every tag in the HTML form.
614
615    set newhtml ""
616   
617    set html_piece_ben $htmlpiece
618
619    set num_vars 0
620
621    for {set i 0} {$i<[ns_set size $values]} {incr i} {
622        if {[ns_set key $values $i] != ""} {
623            set database_values([ns_set key $values $i]) [philg_quote_double_quotes [ns_set value $values $i]]
624            incr num_vars
625        } 
626    }
627
628    set vv {[Vv][Aa][Ll][Uu][Ee]}     ; # Sorta obvious
629    set nn {[Nn][Aa][Mm][Ee]}         ; # This is too
630    set qq {"([^"]*)"}                ; # Matches what's in quotes
631    set pp {([^ ]*)}                  ; # Matches a word (mind yer pp and qq)
632
633    set slist {}
634   
635    set count 0
636
637    while {1} {
638
639        incr count
640        set start_point [string first < $html_piece_ben]
641        if {$start_point==-1} {
642            append newhtml $html_piece_ben
643            break;
644        }
645        if {$start_point>0} {
646            append newhtml [string range $html_piece_ben 0 [expr $start_point - 1]]
647        }
648        set end_point [string first > $html_piece_ben]
649        if {$end_point==-1} break
650        incr start_point
651        incr end_point -1
652        set tag [string range $html_piece_ben $start_point $end_point]
653        incr end_point 2
654        set html_piece_ben [string range $html_piece_ben $end_point end]
655        set CAPTAG [string toupper $tag]
656
657        set first_white [string first " " $CAPTAG]
658        set first_word [string range $CAPTAG 0 [expr $first_white - 1]]
659       
660        switch -regexp $CAPTAG {
661           
662            {^INPUT} {
663                if {[regexp {TYPE[ ]*=[ ]*("IMAGE"|"SUBMIT"|"RESET"|IMAGE|SUBMIT|RESET)} $CAPTAG]} {
664                   
665                    ###
666                    #   Ignore these
667                    ###
668                   
669                    append newhtml <$tag>
670                   
671                } elseif {[regexp {TYPE[ ]*=[ ]*("CHECKBOX"|CHECKBOX)} $CAPTAG]} {
672                    # philg and jesse added optional whitespace 8/9/97
673                    ## If it's a CHECKBOX, we cycle through
674                    #  all the possible ns_set pair to see if it should
675                    ## end up CHECKED or not.
676                   
677                    if {[regexp "$nn=$qq" $tag m nam]} {}\
678                            elseif {[regexp "$nn=$pp" $tag m nam]} {}\
679                            else {set nam ""}
680                   
681                    if {[regexp "$vv=$qq" $tag m val]} {}\
682                            elseif {[regexp "$vv=$pp" $tag m val]} {}\
683                            else {set val ""}
684                   
685                    regsub -all {[Cc][Hh][Ee][Cc][Kk][Ee][Dd]} $tag {} tag
686                   
687                    # support for multiple check boxes provided by michael cleverly
688                    if {[info exists database_values($nam)]} {
689                        if {[ns_set unique $values $nam]} {
690                            if {$database_values($nam) == $val} {
691                                append tag " checked"
692                                incr num_vars -1
693                            }
694                        } else {
695                            for {set i [ns_set find $values $nam]} {$i < [ns_set size $values]} {incr i} {
696                                if {[ns_set key $values $i] == $nam && [philg_quote_double_quotes [ns_set value $values $i]] == $val} {
697                                    append tag " checked"
698                                    incr num_vars -1
699                                    break
700                                }
701                            }
702                        }
703                    }
704
705                    append newhtml <$tag>
706                   
707                } elseif {[regexp {TYPE[ ]*=[ ]*("RADIO"|RADIO)} $CAPTAG]} {
708                   
709                    ## If it's a RADIO, we remove all the other
710                    #  choices beyond the first to keep from having
711                    ## more than one CHECKED
712                   
713                    if {[regexp "$nn=$qq" $tag m nam]} {}\
714                            elseif {[regexp "$nn=$pp" $tag m nam]} {}\
715                            else {set nam ""}
716                   
717                    if {[regexp "$vv=$qq" $tag m val]} {}\
718                            elseif {[regexp "$vv=$pp" $tag m val]} {}\
719                            else {set val ""}
720                   
721                    #Modified by Ben Adida (ben@mit.edu) so that
722                    # the checked tags are eliminated only if something
723                    # is in the database.
724                   
725                    if {[info exists database_values($nam)]} {
726                        regsub -all {[Cc][Hh][Ee][Cc][Kk][Ee][Dd]} $tag {} tag
727                        if {$database_values($nam)==$val} {
728                            append tag " checked"
729                            incr num_vars -1
730                        }
731                    }
732                   
733                    append newhtml <$tag>
734                   
735                } else {
736                   
737                    ## If it's an INPUT TYPE that hasn't been covered
738                    #  (text, password, hidden, other (defaults to text))
739                    ## then we add/replace the VALUE tag
740                   
741                    if {[regexp "$nn=$qq" $tag m nam]} {}\
742                            elseif {[regexp "$nn=$pp" $tag m nam]} {}\
743                            else {set nam ""}
744
745                    set nam [ns_urldecode $nam]
746
747                    if {[info exists database_values($nam)]} {
748                        regsub -all "$vv=$qq" $tag {} tag
749                        regsub -all "$vv=$pp" $tag {} tag
750                        append tag " value=\"$database_values($nam)\""
751                        incr num_vars -1
752                    } else {
753                        if {[regexp {ColValue.([^.]*).([^ ]*)} $tag all nam type]} {
754                            set nam [ns_urldecode $nam]
755                            set typ ""
756                            if {[string match $type "day"]} {
757                                set typ "day"
758                            }
759                            if {[string match $type "year"]} {
760                                set typ "year"
761                            }
762                            if {$typ != ""} {
763                                if {[info exists database_values($nam)]} {
764                                    regsub -all "$vv=$qq" $tag {} tag
765                                    regsub -all "$vv=$pp" $tag {} tag
766                                    append tag " value=\"[ns_parsesqldate $typ $database_values($nam)]\""
767                                }
768                            }
769                            #append tag "><nam=$nam type=$type typ=$typ"
770                        }
771                    }
772                    append newhtml <$tag>
773                }
774            }
775           
776            {^TEXTAREA} {
777               
778                ###
779                #   Fill in the middle of this tag
780                ###
781               
782                if {[regexp "$nn=$qq" $tag m nam]} {}\
783                        elseif {[regexp "$nn=$pp" $tag m nam]} {}\
784                        else {set nam ""}
785               
786                if {[info exists database_values($nam)]} {
787                    while {![regexp {^<( *)/[Tt][Ee][Xx][Tt][Aa][Rr][Ee][Aa]} $html_piece_ben]} {
788                        regexp {^.[^<]*(.*)} $html_piece_ben m html_piece_ben
789                    }
790                    append newhtml <$tag>$database_values($nam)
791                    incr num_vars -1
792                } else {
793                    append newhtml <$tag>
794                }
795            }
796           
797            {^SELECT} {
798               
799                ###
800                #   Set the snam flag, and perhaps smul, too
801                ###
802               
803                set smul [regexp "MULTIPLE" $CAPTAG]
804               
805                set sflg 1
806               
807                set select_date 0
808               
809                if {[regexp "$nn=$qq" $tag m snam]} {}\
810                        elseif {[regexp "$nn=$pp" $tag m snam]} {}\
811                        else {set snam ""}
812
813                set snam [ns_urldecode $snam]
814
815                # In case it's a date
816                if {[regexp {ColValue.([^.]*).month} $snam all real_snam]} {
817                    if {[info exists database_values($real_snam)]} {
818                        set snam $real_snam
819                        set select_date 1
820                    }
821                }
822               
823                lappend slist $snam
824               
825                append newhtml <$tag>
826            }
827           
828            {^OPTION} {
829               
830                ###
831                #   Find the value for this
832                ###
833               
834                if {$snam != ""} {
835                   
836                    if {[lsearch -exact $slist $snam] != -1} {regsub -all {[Ss][Ee][Ll][Ee][Cc][Tt][Ee][Dd]} $tag {} tag}
837                   
838                    if {[regexp "$vv *= *$qq" $tag m opt]} {}\
839                            elseif {[regexp "$vv *= *$pp" $tag m opt]} {}\
840                            else {
841                        if {[info exists opt]} {
842                            unset opt
843                    }   }
844                    # at this point we've figured out what the default from the form was
845                    # and put it in $opt (if the default was spec'd inside the OPTION tag
846                    # just in case it wasn't, we're going to look for it in the
847                    # human-readable part
848                    regexp {^([^<]*)(.*)} $html_piece_ben m txt html_piece_ben
849                    if {![info exists opt]} {
850                        set val [string trim $txt]
851                    } else {
852                        set val $opt
853                    }
854                   
855                    if {[info exists database_values($snam)]} {
856                        # If we're dealing with a date
857                        if {$select_date == 1} {
858                            set db_val [ns_parsesqldate month $database_values($snam)]
859                        } else {
860                            set db_val $database_values($snam)
861                        }
862
863                        if {
864                            ($smul || $sflg) &&
865                            [string match $db_val $val]
866                        } then {
867                            append tag " selected"
868                            incr num_vars -1
869                            set sflg 0
870                        }
871                    }
872                }
873                append newhtml <$tag>$txt
874            }
875           
876            {^/SELECT} {
877                   
878                ###
879                #   Do we need to add to the end?
880                ###
881               
882                set txt ""
883               
884                if {$snam != ""} {
885                    if {[info exists database_values($snam)] && $sflg} {
886                        append txt "<option selected>$database_values($snam)"
887                        incr num_vars -1
888                        if {!$smul} {set snam ""}
889                    }
890                }
891               
892                append newhtml $txt<$tag>
893            }
894           
895            {default} {
896                append newhtml <$tag>
897            }
898        }
899       
900    }
901    return $newhtml
902}
903
904
905
906# database stuff
907
908
909proc_doc GetColumnNames {db table} "returns a list with the column names of the table" {
910    #returns a list with the column names of the table
911    set size [ns_column count $db $table]
912    set i 0
913    set column_names ""
914    while {$i<$size} {
915        lappend column_names [ns_column name $db $table $i]
916        incr i
917    }
918    return $column_names;
919}
920
921proc util_GetNewIDNumber {id_name db} {
922
923    ns_db dml $db "begin transaction;"
924    ns_db dml $db "update id_numbers set $id_name = $id_name + 1;"
925    set id_number [ns_set value\
926            [ns_db 1row $db "select unique $id_name from id_numbers;"] 0]
927    ns_db dml $db "end transaction;"
928
929    return $id_number
930
931}
932
933proc util_prepare_update {db table_name primary_key_name primary_key_value form} {
934
935    set form_size [ns_set size $form]
936    set form_counter_i 0
937    set column_list [GetColumnNames $db $table_name]
938    while {$form_counter_i<$form_size} {
939
940        set form_var_name [ns_set key $form $form_counter_i]
941        set value [string trim [ns_set value $form $form_counter_i]]
942        if { ($form_var_name != $primary_key_name) && ([lsearch $column_list $form_var_name] != -1) } {
943
944            set column_type [ns_column type $db $table_name $form_var_name]
945
946            # we use the NaviServer built-in function quoted_value
947            # which is part of the nsdb tcl module (util.tcl)
948
949            #Added this to allow dates and such to call things
950            #like "current_date"--this is kludgy and should be
951            #fleshed out
952
953            if {[regexp {date|time} $column_type]&&[regexp -nocase {current} $value]} {
954                set quoted_value $value
955            } else {
956                set quoted_value [ns_dbquotevalue $value $column_type]
957            }
958
959            lappend the_sets "$form_var_name = $quoted_value"
960
961
962        }
963
964        incr form_counter_i
965    }
966
967    set primary_key_type [ns_column type $db $table_name $primary_key_name]
968
969    return "update $table_name\nset [join $the_sets ",\n"] \n where $primary_key_name = [ns_dbquotevalue $primary_key_value $primary_key_type]"
970   
971}
972
973proc util_prepare_update_multi_key {db table_name primary_key_name_list primary_key_value_list form} {
974
975    set form_size [ns_set size $form]
976    set form_counter_i 0
977    while {$form_counter_i<$form_size} {
978
979        set form_var_name [ns_set key $form $form_counter_i]
980        set value [string trim [ns_set value $form $form_counter_i]]
981
982        if { [lsearch -exact $primary_key_name_list $form_var_name] == -1 } {
983
984            # this is not one of the keys
985
986            set column_type [ns_column type $db $table_name $form_var_name]
987
988            # we use the NaviServer built-in function quoted_value
989            # which is part of the nsdb tcl module (util.tcl)
990
991            set quoted_value [ns_dbquotevalue $value $column_type]
992
993            lappend the_sets "$form_var_name = $quoted_value"
994
995
996        }
997
998        incr form_counter_i
999    }
1000
1001    for {set i 0} {$i<[llength $primary_key_name_list]} {incr i} {
1002
1003        set this_key_name [lindex $primary_key_name_list $i]
1004        set this_key_value [lindex $primary_key_value_list $i]
1005        set this_key_type [ns_column type $db $table_name $this_key_name]
1006
1007        lappend key_eqns "$this_key_name = [ns_dbquotevalue $this_key_value $this_key_type]"
1008
1009    }
1010
1011    return "update $table_name\nset [join $the_sets ",\n"] \n where [join $key_eqns " AND "]"
1012   
1013}
1014
1015proc util_prepare_insert {db table_name primary_key_name primary_key_value form} {
1016
1017    set form_size [ns_set size $form]
1018    set form_counter_i 0
1019    while {$form_counter_i<$form_size} {
1020
1021        set form_var_name [ns_set key $form $form_counter_i]
1022        set value [string trim [ns_set value $form $form_counter_i]]
1023
1024        if { $form_var_name != $primary_key_name } {
1025
1026            set column_type [ns_column type $db $table_name $form_var_name]
1027
1028            # we use the NaviServer built-in function quoted_value
1029            # which is part of the nsdb tcl module (util.tcl)
1030
1031            set quoted_value [ns_dbquotevalue $value $column_type]
1032
1033            lappend the_names $form_var_name
1034            lappend the_vals $quoted_value
1035
1036
1037        }
1038
1039        incr form_counter_i
1040    }
1041
1042    set primary_key_type [ns_column type $db $table_name $primary_key_name]
1043
1044    return "insert into $table_name\n($primary_key_name,[join $the_names ","]) \n values ([ns_dbquotevalue $primary_key_value $primary_key_type],[join $the_vals ","])"
1045   
1046}
1047
1048proc util_prepare_insert_string_trim {db table_name primary_key_name primary_key_value form} {
1049
1050    set form_size [ns_set size $form]
1051    set form_counter_i 0
1052    while {$form_counter_i<$form_size} {
1053
1054        set form_var_name [ns_set key $form $form_counter_i]
1055        set value [string trim [ns_set value $form $form_counter_i]]
1056
1057        if { $form_var_name != $primary_key_name } {
1058
1059            set column_type [ns_column type $db $table_name $form_var_name]
1060
1061            # we use the NaviServer built-in function quoted_value
1062            # which is part of the nsdb tcl module (util.tcl)
1063
1064            set quoted_value [ns_dbquotevalue $value $column_type]
1065
1066            lappend the_names $form_var_name
1067            lappend the_vals $quoted_value
1068
1069
1070        }
1071
1072        incr form_counter_i
1073    }
1074
1075    set primary_key_type [ns_column type $db $table_name $primary_key_name]
1076
1077    return "insert into $table_name\n($primary_key_name,[join $the_names ","]) \n values ([ns_dbquotevalue $primary_key_value $primary_key_type],[join $the_vals ","])"
1078   
1079}
1080
1081proc util_prepare_insert_no_primary_key {db table_name form} {
1082
1083    set form_size [ns_set size $form]
1084    set form_counter_i 0
1085    while {$form_counter_i<$form_size} {
1086
1087        set form_var_name [ns_set key $form $form_counter_i]
1088        set value [string trim [ns_set value $form $form_counter_i]]
1089
1090        set column_type [ns_column type $db $table_name $form_var_name]
1091
1092        # we use the NaviServer built-in function quoted_value
1093        # which is part of the nsdb tcl module (util.tcl)
1094
1095        set quoted_value [ns_dbquotevalue $value $column_type]
1096
1097        lappend the_names $form_var_name
1098        lappend the_vals $quoted_value
1099
1100        incr form_counter_i
1101    }
1102
1103
1104    return "insert into $table_name\n([join $the_names ","]) \n values ([join $the_vals ","])"
1105   
1106}
1107
1108proc util_PrettySex {m_or_f { default "default" }} {
1109    if { $m_or_f == "M" || $m_or_f == "m" } {
1110        return "Male"
1111    } elseif { $m_or_f == "F" || $m_or_f == "f" } {
1112        return "Female"
1113    } else {
1114        # Note that we can't compare default to the empty string as in
1115        # many cases, we are going want the default to be the empty
1116        # string
1117        if { [string compare $default "default"] == 0 } {
1118            return "Unknown (\"$m_or_f\")"
1119        } else {
1120            return $default
1121        }
1122    }
1123}
1124
1125proc util_PrettySexManWoman {m_or_f { default "default"} } {
1126    if { $m_or_f == "M" || $m_or_f == "m" } {
1127        return "Man"
1128    } elseif { $m_or_f == "F" || $m_or_f == "f" } {
1129        return "Woman"
1130    } else {
1131        # Note that we can't compare default to the empty string as in
1132        # many cases, we are going want the default to be the empty
1133        # string
1134        if { [string compare $default "default"] == 0 } {
1135            return "Person of Unknown Sex"
1136        } else {
1137            return $default
1138        }
1139    }
1140}
1141
1142proc util_PrettyBoolean {t_or_f { default  "default" } } {
1143    if { $t_or_f == "t" || $t_or_f == "T" } {
1144        return "Yes"
1145    } elseif { $t_or_f == "f" || $t_or_f == "F" } {
1146        return "No"
1147    } else {
1148        # Note that we can't compare default to the empty string as in
1149        # many cases, we are going want the default to be the empty
1150        # string
1151        if { [string compare $default "default"] == 0 } {
1152            return "Unknown (\"$t_or_f\")"
1153        } else {
1154            return $default
1155        }
1156    }
1157}
1158
1159
1160proc_doc util_PrettyTclBoolean {zero_or_one} "Turns a 1 (or anything else that makes a Tcl IF happy) into Yes; anything else into No" {
1161    if $zero_or_one {
1162        return "Yes"
1163    } else {
1164        return "No"
1165    }
1166}
1167
1168# Pre-declare the cache arrays used in util_memoize.
1169nsv_set util_memorize_cache_value . ""
1170nsv_set util_memorize_cache_timestamp . ""
1171
1172proc_doc util_memoize {tcl_statement {oldest_acceptable_value_in_seconds ""}} "Returns the result of evaluating the Tcl statement argument and then remembers that value in a cache; the memory persists for the specified number of seconds (or until the server is restarted if the second argument is not supplied) or until someone calls util_memoize_flush with the same Tcl statement.  Note that this procedure should be used with care because it calls the eval built-in procedure (and therefore an unscrupulous user could  " {
1173
1174    # we look up the statement in the cache to see if it has already
1175    # been eval'd.  The statement itself is the key
1176
1177    if { ![nsv_exists util_memorize_cache_value $tcl_statement] || ( ![empty_string_p $oldest_acceptable_value_in_seconds] && ([expr [nsv_get util_memorize_cache_timestamp $tcl_statement] + $oldest_acceptable_value_in_seconds] < [ns_time]) )} {
1178
1179        # not in the cache already OR the caller spec'd an expiration
1180        # time and our cached value is too old
1181
1182        set statement_value [eval $tcl_statement]
1183        nsv_set util_memorize_cache_value $tcl_statement $statement_value
1184        # store the time in seconds since 1970
1185        nsv_set util_memorize_cache_timestamp $tcl_statement [ns_time]
1186    }
1187
1188    return [nsv_get util_memorize_cache_value $tcl_statement]
1189}
1190
1191# flush the cache
1192
1193proc_doc util_memoize_flush {tcl_statement} "Flush the cached value (established with util_memoize associated with the argument)" {
1194
1195    if [nsv_exists util_memorize_cache_value $tcl_statement] {
1196        nsv_unset util_memorize_cache_value $tcl_statement
1197    }
1198    if [nsv_exists util_memorize_cache_timestamp $tcl_statement] {
1199        nsv_unset util_memorize_cache_timestamp $tcl_statement
1200    }
1201}
1202
1203proc_doc util_memoize_value_cached_p {tcl_statement {oldest_acceptable_value_in_seconds ""}} "Returns 1 if there is a cached value for this Tcl expression.  If a second argument is supplied, only returns 1 if the cached value isn't too old." {
1204
1205    # we look up the statement in the cache to see if it has already
1206    # been eval'd.  The statement itself is the key
1207
1208    if { ![nsv_exists util_memorize_cache_value $tcl_statement] || ( ![empty_string_p $oldest_acceptable_value_in_seconds] && ([expr [nsv_get util_memorize_cache_timestamp $tcl_statement] + $oldest_acceptable_value_in_seconds] < [ns_time]) )} {
1209        return 0
1210    } else {
1211        return 1
1212    }   
1213}
1214
1215
1216proc current_year {db} {
1217    util_memoize "current_year_internal $db"
1218}
1219
1220proc current_year_internal {db} {
1221
1222    database_to_tcl_string $db "return extract(year from current_date)"
1223
1224}
1225
1226proc philg_server_default_pool {} {
1227    set server_name [ns_info server]
1228    append config_path "ns\\server\\" $server_name "\\db"
1229    set default_pool [ns_config $config_path DefaultPool]
1230    return $default_pool
1231}
1232
1233# this is typically called like this...
1234# philg_urldecode_form_variable [ns_getform]
1235# and it is called for effect, not value
1236# we use it if we've urlencoded something for a hidden
1237# variable (e.g., to escape the string quotes) in a form
1238
1239proc philg_urldecode_form_variable {form variable_name} {
1240    set old_value [ns_set get $form $variable_name]
1241    set new_value [ns_urldecode $old_value]
1242    # one has to delete the old value first, otherwise
1243    # you just get two values for the same key in the ns_set
1244    ns_set delkey $form $variable_name
1245    ns_set put $form $variable_name $new_value
1246}
1247
1248proc util_convert_plaintext_to_html {raw_string} {
1249    if { [regexp -nocase {<p>} $raw_string] || [regexp -nocase {<br>} $raw_string] } {
1250        # user was already trying to do this as HTML
1251        return $raw_string
1252    } else {
1253        # quote <, >, and &
1254        set clean_for_html [ns_quotehtml $raw_string]
1255        # turn CRLFCRLF into <P>
1256        if { [regsub -all "\015\012\015\012" $clean_for_html "\n\n<p>\n\n" clean_for_html] == 0 } {
1257            # try LFLF
1258            if { [regsub -all "\012\012" $clean_for_html "\n\n<p><p>\n\n" clean_for_html] == 0 } {
1259                # try CRCR
1260                regsub -all "\015\015" $clean_for_html "\n\n<p><p>\n\n" clean_for_html
1261            }
1262        }
1263        return $clean_for_html
1264    }
1265}
1266
1267proc_doc util_maybe_convert_to_html {raw_string html_p} "very useful for info pulled from the news, neighbor, events subsystems."  {
1268    if { $html_p == "t" } {
1269        return $raw_string
1270    } else {
1271        return [util_convert_plaintext_to_html $raw_string]
1272    }
1273}
1274
1275
1276# turn " into &quot; before using strings inside hidden vars
1277# patched on May 31, 1999 by philg to also quote >, <, and &
1278# fixed a bug in /bboard/confirm
1279
1280proc philg_quote_double_quotes {arg} {
1281    # we have to do & first or we'll hose ourselves with the ones lower down
1282    regsub -all & $arg \\&amp\; arg
1283    regsub -all \" $arg \\&quot\; arg
1284    regsub -all < $arg \\&lt\; arg
1285    regsub -all > $arg \\&gt\; arg
1286    return $arg
1287}
1288
1289# stuff that will let us do what ns_striphtml does but a little better
1290
1291proc_doc util_striphtml {html} {Returns a best-guess plain text version of an HTML fragment.  Better than ns_striphtml because it doesn't replace & g t ; and & l t ; with empty string.} {
1292    return [util_expand_entities [util_remove_html_tags $html]]
1293}
1294
1295proc util_remove_html_tags {html} {
1296   regsub -all {<[^>]*>} $html {} html
1297   return $html
1298}
1299
1300proc util_expand_entities {html} {
1301   regsub -all {&lt;} $html {<} html
1302   regsub -all {&gt;} $html {>} html
1303   regsub -all {&quot;} $html {"} html
1304   regsub -all {&amp;} $html {\&} html
1305   return $html
1306}
1307
1308proc util_GetUserAgentHeader {} {
1309    set header [ns_conn headers]
1310
1311    # note that this MUST be case-insensitive search (iget)
1312    # due to a NaviServer bug -- philg 2/1/96
1313
1314    set userag [ns_set iget $header "USER-AGENT"]
1315    return $userag
1316}
1317
1318proc msie_p {} {
1319    return [regexp -nocase {msie} [util_GetUserAgentHeader]]
1320}
1321
1322proc submit_button_if_msie_p {} {
1323    if { [msie_p] } {
1324        return "<input type=submit>"
1325    } else {
1326        return ""
1327    }
1328}
1329
1330proc randomInit {seed} {
1331    nsv_set rand ia 9301
1332    nsv_set rand ic 49297
1333    nsv_set rand im 233280
1334    nsv_set rand seed $seed
1335}
1336
1337# initialize the random number generator
1338
1339randomInit [ns_time]
1340
1341proc random {} {
1342    nsv_set rand seed [expr ([nsv_get rand seed] * [nsv_get rand ia] + [nsv_get rand ic]) % [nsv_get rand im]]
1343    return [expr [nsv_get rand seed]/double([nsv_get rand im])]
1344}
1345
1346proc randomRange {range} {
1347    return [expr int([random] * $range)]
1348}
1349
1350proc capitalize {word} {
1351    if {$word != ""} {
1352        set newword ""
1353        if [regexp {[^ ]* [^ ]*} $word] {
1354            set words [split $word]
1355            foreach part $words {
1356                set newword "$newword [capitalize $part]"
1357            }
1358        } else {
1359            regexp {^(.)(.*)$} $word match firstchar rest
1360            set newword [string toupper $firstchar]$rest
1361        }
1362        return [string trim $newword]
1363    }
1364    return $word
1365}
1366
1367proc html_select_options {options {select_option ""}} {
1368    #this is html to be placed into a select tag
1369    set select_options ""
1370    foreach option $options {
1371        if { [lsearch $select_option $option] != -1 } {
1372            append select_options "<option selected>$option\n"
1373        } else {
1374            append select_options "<option>$option\n"
1375        }
1376    }
1377    return $select_options
1378}
1379
1380proc db_html_select_options {db query {select_option ""}} {
1381    #this is html to be placed into a select tag
1382    set select_options ""
1383    set options [database_to_tcl_list $db $query]
1384    foreach option $options {
1385        if { [string compare $option $select_option] == 0 } {
1386            append select_options "<option selected>$option\n"
1387        } else {
1388            append select_options "<option>$option\n"
1389        }
1390    }
1391    return $select_options
1392}
1393
1394proc html_select_value_options {options {select_option ""} {value_index 0} {option_index 1}} {
1395    #this is html to be placed into a select tag
1396    #when value!=option, set the index of the return list
1397    #from the db query. selected option must match value
1398
1399    set select_options ""
1400    foreach option $options {
1401        if { [lsearch $select_option [lindex $option $value_index]] != -1 } {
1402            append select_options "<option value=[lindex $option $value_index] selected>[lindex $option $option_index]\n"
1403        } else {
1404            append select_options "<option value=[lindex $option $value_index]>[lindex $option $option_index]\n"
1405        }
1406    }
1407    return $select_options
1408}
1409
1410proc db_html_select_value_options {db query {select_option ""} {value_index 0} {option_index 1}} {
1411    #this is html to be placed into a select tag
1412    #when value!=option, set the index of the return list
1413    #from the db query. selected option must match value
1414
1415    set select_options ""
1416    set options [database_to_tcl_list_list $db $query]
1417    foreach option $options {
1418        if { [lsearch $select_option [lindex $option $value_index]] != -1 } {
1419            append select_options "<option value=[lindex $option $value_index] selected>[lindex $option $option_index]\n"
1420        } else {
1421            append select_options "<option value=[lindex $option $value_index]>[lindex $option $option_index]\n"
1422        }
1423    }
1424    return $select_options
1425}
1426
1427# new philg kludges
1428
1429# produces a safe-for-browsers hidden variable, i.e., one where
1430# " has been replaced by &quot;
1431
1432proc philg_hidden_input {name value} {
1433    return "<input type=hidden name=\"$name\" value=\"[philg_quote_double_quotes $value]\">"
1434}
1435
1436# this REGEXP was very kindly contributed by Jeff Friedl, author of
1437# _Mastering Regular Expressions_ (O'Reilly 1997)
1438proc_doc philg_email_valid_p {query_email} "Returns 1 if an email address has more or less the correct form" {
1439    return [regexp "^\[^@\t ]+@\[^@.\t]+(\\.\[^@.\n ]+)+$" $query_email]
1440}
1441
1442proc_doc philg_url_valid_p {query_url} "Returns 1 if a URL has more or less the correct form." {
1443    return [regexp {http://.+} $query_url]
1444}
1445
1446# just checking it for format, not semantics
1447
1448proc philg_date_valid_p {query_date} {
1449    return [regexp {[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]} $query_date]
1450}
1451# Return a string of hidden input fields for a form to pass along any
1452# of the parameters in args if they exist in the current environment.
1453#  -- jsc@arsdigita.com
1454
1455# usage:  [export_form_vars foo bar baz]
1456
1457proc export_form_vars args {
1458    set hidden ""
1459    foreach var $args {
1460        upvar 1 $var value
1461        if { [info exists value] } {
1462            append hidden "<input type=hidden name=$var value=\"[philg_quote_double_quotes $value]\">\n"
1463        }
1464    }
1465    return $hidden
1466}
1467
1468proc export_entire_form {} {
1469    set hidden ""
1470    set the_form [ns_getform]
1471    for {set i 0} {$i<[ns_set size $the_form]} {incr i} {
1472        set varname [ns_set key $the_form $i]
1473        set varvalue [ns_set value $the_form $i]
1474        append hidden "<input type=hidden name=\"$varname\" value=\"[philg_quote_double_quotes $varvalue]\">\n"
1475    }
1476    return $hidden
1477}
1478
1479
1480proc_doc export_ns_set_vars {{format "url"} {exclusion_list ""}  {setid ""}} "Returns all the params in an ns_set with the exception of those in exclusion_list. If no setid is provide, ns_getform is used. If format = url, a url parameter string will be returned. If format = form, a block of hidden form fragments will be returned."  {
1481
1482    if [empty_string_p $setid] {
1483        set setid [ns_getform]
1484    }
1485
1486    set return_list [list]
1487    if ![empty_string_p $setid] {
1488        set set_size [ns_set size $setid]
1489        set set_counter_i 0
1490        while { $set_counter_i<$set_size } {
1491            set name [ns_set key $setid $set_counter_i]
1492            set value [ns_set value $setid $set_counter_i]
1493            if {[lsearch $exclusion_list $name] == -1 && ![empty_string_p $name]} {
1494                if {$format == "url"} {
1495                    lappend return_list "$name=[ns_urlencode $value]"
1496                } else {
1497                    lappend return_list " name=$name value=\"[philg_quote_double_quotes $value]\""
1498                }
1499            }
1500            incr set_counter_i
1501        }
1502    }
1503    if {$format == "url"} {
1504        return [join $return_list "&"]
1505    } else {
1506        return "<input type=hidden [join $return_list ">\n <input type=hidden "] >"
1507    }
1508}
1509
1510
1511# Return a URL parameter string passing along all the parameters
1512# given to it as arguments, if they exist in the current environment.
1513# -- jsc@arsdigita.com
1514proc_doc export_url_vars args "Returns a string of key=value pairs suitable for inclusion in a URL; you can pass it any number of variables as arguments.  If any are defined in the caller's environment, they are included.  See also export_entire_form_as_url_vars" { 
1515    set params {} 
1516    foreach var $args { 
1517        upvar 1 $var value
1518        if { [info exists value] } {
1519            lappend params "$var=[ns_urlencode $value]" 
1520        } 
1521    } 
1522    return [join $params "&"] 
1523} 
1524 
1525proc_doc export_entire_form_as_url_vars {{vars_to_passthrough ""}} "Returns a URL parameter string of name-value pairs of all the form parameters passed to this page. If vars_to_passthrough is given, it should be a list of parameter names that will be the only ones passed through." {
1526    set params [list]
1527    set the_form [ns_getform]
1528    for {set i 0} {$i<[ns_set size $the_form]} {incr i} {
1529        set varname [ns_set key $the_form $i]
1530        set varvalue [ns_set value $the_form $i]
1531        if { $vars_to_passthrough == "" || ([lsearch -exact $vars_to_passthrough $varname] != -1) } {
1532            lappend params "$varname=[ns_urlencode $varvalue]" 
1533        }
1534    }
1535    return [join $params "&"]
1536}
1537
1538
1539# we use this to shut off spam scheduling and such
1540# it asks the question "is this just a development server"?
1541
1542# we write DevelopmentServer=1 into the server portion of the .ini file
1543
1544# [ns/server/philg]
1545# DevelopmentServer=1
1546
1547
1548proc philg_development_p {} {
1549    set config_param [ns_config "ns/server/[ns_info server]" DevelopmentServer]
1550    if { $config_param == 1 } {
1551        return 1
1552    } else {
1553        return 0
1554    }
1555}
1556
1557proc philg_keywords_match {keywords string_to_search} {
1558    # turn keywords into space-separated things
1559    # replace one or more commads with a space
1560    regsub -all {,+} $keywords " " keywords_no_commas
1561    set keyword_list [split $keywords_no_commas " "]
1562    set found_p 0
1563    foreach word $keyword_list {
1564        # turns out that "" is never found in a search, so we
1565        # don't really have to special case $word == ""
1566        if { $word != "" && [string first [string toupper $word] [string toupper $string_to_search]] != -1 } {
1567            # found it!
1568            set found_p 1
1569        }
1570    }
1571    return $found_p
1572}
1573
1574proc_doc philg_keywords_score {keywords string_to_search} "Takes space-separated keywords and returns 0 if none are found or a count of how many matched.  If a keyword occurs twice then it is weighted 2." {
1575    # turn keywords into space-separated things
1576    # replace one or more commads with a space
1577    regsub -all {,+} $keywords " " keywords_no_commas
1578    set keyword_list [split $keywords_no_commas " "]
1579    set score 0
1580    foreach word $keyword_list {
1581        # turns out that "" is never found in a search, so we
1582        # don't really have to special case $word == ""
1583        if { $word != "" && [string first [string toupper $word] [string toupper $string_to_search]] != -1 } {
1584            # found at least one!
1585            if { [string first [string toupper $word] [string toupper $string_to_search]] == [string last [string toupper $word] [string toupper $string_to_search]] } {
1586                # only one occurrence
1587                incr score
1588            } else {
1589                # more than one, count as 2 (like AltaVista)
1590                incr score 2
1591            }
1592        }
1593    }
1594    return $score
1595}
1596
1597# usage:
1598#   suppose the variable is called "expiration_date"
1599#   put "[philg_dateentrywidget expiration_date]" in your form
1600#     and it will expand into lots of weird generated var names
1601#   put ns_dbformvalue [ns_getform] expiration_date date expiration_date
1602#     and whatever the user typed will be set in $expiration_date
1603
1604proc philg_dateentrywidget {column {default_date "1940-11-03"}} {
1605    ns_share NS
1606
1607    set output "<SELECT name=ColValue.[ns_urlencode $column].month>\n"
1608    for {set i 0} {$i < 12} {incr i} {
1609        append output "<OPTION> [lindex $NS(months) $i]\n"
1610    }
1611
1612    append output \
1613"</SELECT>&nbsp;<INPUT NAME=ColValue.[ns_urlencode $column].day\
1614TYPE=text SIZE=3 MAXLENGTH=2>&nbsp;<INPUT NAME=ColValue.[ns_urlencode $column].year\
1615TYPE=text SIZE=5 MAXLENGTH=4>"
1616
1617    return [ns_dbformvalueput $output $column date $default_date]
1618}
1619
1620proc philg_dateentrywidget_default_to_today {column} {
1621    set today [lindex [split [ns_localsqltimestamp] " "] 0]
1622    return [philg_dateentrywidget $column $today]
1623}
1624
1625# Perform the dml statements in sql_list in a transaction.
1626# Aborts the transaction and returns an error message if
1627# an error occurred for any of the statements, otherwise
1628# returns null string. -jsc
1629proc do_dml_transactions {db sql_list} {
1630    ns_db dml $db "begin transaction"
1631    foreach stmt $sql_list {
1632        if [catch {ns_db dml $db $stmt} errmsg] {
1633            ns_db dml $db "abort transaction"
1634            return $errmsg
1635        }
1636    }
1637    ns_db dml $db "end transaction"
1638    return ""
1639}
1640
1641# Perform body within a database transaction.
1642# Execute on_error if there was some error caught
1643# within body, with errmsg bound.
1644# This procedure will clobber errmsg in the caller.
1645# -jsc
1646proc with_transaction {db body on_error} {
1647    upvar errmsg errmsg
1648    global errorInfo errorCode
1649    if [catch {ns_db dml $db "begin transaction"
1650               uplevel $body
1651               ns_db dml $db "end transaction"} errmsg] {
1652        ns_db dml $db "abort transaction"
1653        set code [catch {uplevel $on_error} string]
1654        # Return out of the caller appropriately.
1655        if { $code == 1 } {
1656            return -code error -errorinfo $errorInfo -errorcode $errorCode $string
1657        } elseif { $code == 2 } {
1658            return -code return $string
1659        } elseif { $code == 3 } {
1660            return -code break
1661        } elseif { $code == 4 } {
1662            return -code continue
1663        } elseif { $code > 4 } {
1664            return -code $code $string
1665        }
1666    }       
1667}
1668
1669proc with_catch {error_var body on_error} { 
1670    upvar 1 $error_var $error_var 
1671    global errorInfo errorCode
1672    if [catch { uplevel $body } $error_var] { 
1673        set code [catch {uplevel $on_error} string] 
1674        # Return out of the caller appropriately.
1675        if { $code == 1 } { 
1676            return -code error -errorinfo $errorInfo -errorcode $errorCode $string 
1677        } elseif { $code == 2 } { 
1678            return -code return $string 
1679        } elseif { $code == 3 } { 
1680            return -code break
1681        } elseif { $code == 4 } {
1682            return -code continue
1683        } elseif { $code > 4 } { 
1684            return -code $code $string 
1685        } 
1686    }         
1687} 
1688
1689proc_doc empty_string_p {query_string} "returns 1 if a string is empty; this is better than using == because it won't fail on long strings of numbers" {
1690    if { [string compare $query_string ""] == 0 } {
1691        return 1
1692    } else {
1693        return 0
1694    }
1695}
1696
1697proc_doc string_contains_p {small_string big_string} {Returns 1 if the BIG_STRING contains the SMALL_STRING, 0 otherwise; syntactic sugar for string first != -1} {
1698    if { [string first $small_string $big_string] == -1 } {
1699        return 0
1700    } else {
1701        return 1
1702    }
1703}
1704
1705# -- philg had this at Primehost
1706
1707# take a string and wrap it to 80 columns max this does not justify
1708# text, only insert line breaks
1709
1710proc_doc wrap_string {input {threshold 80}} "wraps a string to be no wider than 80 columns by inserting line breaks" {
1711    set result_rows [list]
1712    set start_of_line_index 0
1713    while 1 {
1714        set this_line [string range $input $start_of_line_index [expr $start_of_line_index + $threshold - 1]]
1715        if { $this_line == "" } {
1716            return [join $result_rows "\n"]
1717        }
1718        set first_new_line_pos [string first "\n" $this_line]
1719        if { $first_new_line_pos != -1 } {
1720            # there is a newline
1721            lappend result_rows [string range $input $start_of_line_index [expr $start_of_line_index + $first_new_line_pos - 1]]
1722            set start_of_line_index [expr $start_of_line_index + $first_new_line_pos + 1]
1723            continue
1724        }
1725        if { [expr $start_of_line_index + $threshold + 1] >= [string length $input] } {
1726            # we're on the last line and it is < threshold so just return it
1727                lappend result_rows $this_line
1728                return [join $result_rows "\n"]
1729        }
1730        set last_space_pos [string last " " $this_line]
1731        if { $last_space_pos == -1 } {
1732            # no space found!  Try the first space in the whole rest of the string
1733            set $last_space_pos [string first " " [string range $input $start_of_line_index end]]
1734            if { $last_space_pos == -1 } {
1735                # didn't find any more spaces, append the whole thing as a line
1736                lappend result_rows [string range $input $start_of_line_index end]
1737                return [join $result_rows "\n"]
1738            }
1739        }
1740        # OK, we have a last space pos of some sort
1741        set real_index_of_space [expr $start_of_line_index + $last_space_pos]
1742        lappend result_rows [string range $input $start_of_line_index [expr $real_index_of_space - 1]]
1743        set start_of_line_index [expr $start_of_line_index + $last_space_pos + 1]
1744    }
1745}
1746
1747proc remove_whitespace {input_string} {
1748    if [regsub -all "\[\015\012\t \]" $input_string "" output_string] {
1749        return $output_string 
1750    } else {
1751        return $input_string
1752    }
1753}
1754
1755proc util_just_the_digits {input_string} {
1756    if [regsub -all {[^0-9]} $input_string "" output_string] {
1757        return $output_string 
1758    } else {
1759        return $input_string
1760    }
1761}
1762
1763# sort of the opposite (for phone numbers, takes
1764# 6172538574 and turns it into "(617) 253-8574")
1765
1766proc philg_format_phone_number {just_the_digits} {
1767    if { [string length $just_the_digits] != 10 } {
1768        return $just_the_digits
1769    } else {
1770        return "([string range $just_the_digits 0 2]) [string range $just_the_digits 3 5]-[string range $just_the_digits 6 9]"
1771    }
1772}
1773
1774# putting commas into numbers (thank you, Michael Bryzek)
1775
1776proc_doc util_commify_number { num } {Returns the number with commas inserted where appropriate. Number can be positive or negative and can have a decimal point. e.g. -1465.98 => -1,465.98} {
1777    while { 1 } {
1778        # Regular Expression taken from mastering regular expressions
1779        # matches optional leading negative sign plus any
1780        # other 3 digits, starting from end
1781        if { ![regsub -- {^(-?[0-9]+)([0-9][0-9][0-9])} $num {\1,\2} num] } {
1782            break
1783        }
1784    }
1785    return $num
1786}
1787
1788# for limiting a string to 4000 characters because the Oracle SQL
1789# parser is so stupid and can only handle a string literal that long
1790
1791proc util_limit_to_4000_chars {input_string} {
1792    return [string range $input_string 0 3999]
1793}
1794
1795
1796proc leap_year_p {year} {
1797    expr ( $year % 4 == 0 ) && ( ( $year % 100 != 0 ) || ( $year % 400 == 0 ) )
1798}
1799
1800proc_doc ad_proc args {
1801    Use just like proc, but first argument must be a named argument description.
1802    A named argument description is a list of flag/default value pairs:
1803    {-arg1 arg1default -arg2 arg2default}
1804    By jsc@arsdigita.com
1805} {
1806
1807    set proc_name [lindex $args 0]
1808    set ad_args [lindex $args 1]
1809
1810    nsv_set ad_proc_args $proc_name $ad_args
1811
1812    generate_argument_parser $proc_name $ad_args
1813
1814    # Four argument version indicates use of proc_doc instead of proc.
1815    if { [llength $args] == 4 } {
1816        set doc_string [lindex $args 2]
1817        set body [lindex $args 3]
1818        proc_doc $proc_name args $doc_string "arg_parser_for_$proc_name \$args\n$body"
1819    } else {
1820        set body [lindex $args 2]
1821        proc $proc_name args "arg_parser_for_$proc_name \$args\n$body"
1822    }
1823}
1824
1825# Helper function, acts like perl shift:
1826# Return value of first element and remove it from the list.
1827proc shift {list_name} {
1828    upvar 1 $list_name list_to_shift
1829    set first_arg_p 1
1830    set first_arg ""
1831    set rest ""
1832
1833    foreach element $list_to_shift {
1834        if { $first_arg_p } {
1835            set first_arg $element
1836            set first_arg_p 0
1837        } else {
1838            lappend rest $element
1839        }
1840    }
1841    set list_to_shift $rest
1842    return $first_arg
1843}
1844
1845# Helper function: If its argument does not start with "{", surround
1846# it with a pair of braces.
1847proc format_as_list {some_list} {
1848    if { [string index $some_list 0] == "\{" } {
1849        return $some_list
1850    } else {
1851        return "{$some_list}"
1852    }
1853}
1854
1855
1856# Given the name of a procedure and an argument description,
1857# creates a procedure named arg_parser_for_{procedure_name} that
1858# takes an argument list, parses it according to the description,
1859# and sets the parameters in the argument list as variables in
1860# its caller's environment. Named values are set to the value they
1861# are called with, or to the default given in the argument description.
1862proc generate_argument_parser {proc_name argdesc} {
1863    # First argument is named argument description; others are
1864    # regular arguments.
1865    set named_args_desc [shift argdesc]
1866    set rest $argdesc
1867    set named_arg_length [llength $named_args_desc]
1868
1869    # Use the named argument description to generate two hunks of tcl,
1870    # one for initially setting defaults for all the named arguments,
1871    # and another one which will handle those arguments in a switch
1872    # statement.
1873    set flag_clauses ""
1874    set defaults_setting_clauses ""
1875
1876    for {set i 0} {$i < $named_arg_length} {incr i} {
1877        set flag [lindex $named_args_desc $i]
1878        set named_arg [string range $flag 1 end]
1879        incr i
1880        set flag_value [lindex $named_args_desc $i]
1881
1882        append defaults_setting_clauses "
1883            upvar 1 $named_arg $named_arg
1884            set $named_arg \"$flag_value\"
1885        "
1886
1887        append flag_clauses "
1888                        $flag {
1889                            incr i
1890                            upvar 1 $named_arg $named_arg
1891                            set $named_arg \[lindex \$arglist \$i\]
1892                            continue
1893                        }
1894"
1895    }
1896
1897    # Generate the Tcl for creating the argument parser procedure.
1898    set evalstr "proc arg_parser_for_$proc_name arglist {
1899        set regular_arg_names [format_as_list $rest]
1900        set regular_arg_index 0
1901        set regular_arg_length \[llength \$regular_arg_names\]
1902        set parsing_named_args_p 1
1903
1904$defaults_setting_clauses
1905
1906        set arg_length \[llength \$arglist\]
1907        for {set i 0} {\$i < \$arg_length} {incr i} {
1908            set arg \[lindex \$arglist \$i\]
1909
1910            if \$parsing_named_args_p {
1911                if { \[string index \$arg 0\] == \"-\" } {
1912                    switch -- \$arg {
1913                        \"--\" {
1914                            set parsing_named_args_p 0
1915                            continue
1916                        }
1917$flag_clauses
1918                        default {
1919                            error \"Unrecognized argument \$arg\"
1920                        }
1921                    }
1922                } else {
1923                    set parsing_named_args_p 0
1924                }
1925            }
1926
1927            if { !\$parsing_named_args_p } {
1928                if { \$regular_arg_index == \$regular_arg_length } {
1929                    error \"called \\\"$proc_name\\\" with too many arguments\"
1930                }
1931                set regular_arg_name \[lindex \$regular_arg_names \$regular_arg_index\]
1932                incr regular_arg_index
1933                upvar \$regular_arg_name \$regular_arg_name
1934                set \$regular_arg_name \$arg
1935            }
1936        }
1937        if { \$regular_arg_index != \$regular_arg_length } {
1938            error \"too few arguments given for \\\"$proc_name\\\"\"
1939        }
1940    }
1941"
1942    eval $evalstr
1943}
1944
1945proc_doc util_search_list_of_lists {list_of_lists query_string {sublist_element_pos 0}} "Returns position of sublist that contains QUERY_STRING at SUBLIST_ELEMENT_POS." {
1946    set sublist_index 0
1947    foreach sublist $list_of_lists {
1948        set comparison_element [lindex $sublist $sublist_element_pos]
1949        if { [string compare $query_string $comparison_element] == 0 } {
1950            return $sublist_index
1951        }
1952        incr sublist_index
1953    }
1954    # didn't find it
1955    return -1
1956}
1957
1958# --- network stuff
1959
1960proc_doc util_get_http_status {url {use_get_p 1} {timeout 30}} "Returns the HTTP status code, e.g., 200 for a normal response or 500 for an error, of a URL.  By default this uses the GET method instead of HEAD since not all servers will respond properly to a HEAD request even when the URL is perfectly valid.  Note that this means AOLserver may be sucking down a lot of bits that it doesn't need." { 
1961    if $use_get_p {
1962        set http [ns_httpopen GET $url "" $timeout] 
1963    } else {
1964        set http [ns_httpopen HEAD $url "" $timeout] 
1965    }
1966    # philg changed these to close BOTH rfd and wfd
1967    set rfd [lindex $http 0] 
1968    set wfd [lindex $http 1] 
1969    close $rfd
1970    close $wfd
1971    set headers [lindex $http 2] 
1972    set response [ns_set name $headers] 
1973    set status [lindex $response 1] 
1974    ns_set free $headers
1975    return $status
1976}
1977
1978proc_doc util_link_responding_p {url {list_of_bad_codes "404"}} "Returns 1 if the URL is responding (generally we think that anything other than 404 (not found) is okay)." {
1979    if [catch { set status [util_get_http_status $url] } errmsg] {
1980        # got an error; definitely not valid
1981        return 0
1982    } else {
1983        # we got the page but it might have been a 404 or something
1984        if { [lsearch $list_of_bad_codes $status] != -1 } {
1985            return 0
1986        } else {
1987            return 1
1988        }
1989    }
1990}
1991
1992# system by Tracy Adams (teadams@arsdigita.com) to permit AOLserver to POST
1993# to another Web server; sort of like ns_httpget
1994
1995proc_doc util_httpopen {method url {rqset ""} {timeout 30} {http_referer ""}} "Like ns_httpopen but works for POST as well; called by util_httppost" {
1996   
1997        if ![string match http://* $url] {
1998                return -code error "Invalid url \"$url\":  _httpopen only supports HTTP"
1999        }
2000        set url [split $url /]
2001        set hp [split [lindex $url 2] :]
2002        set host [lindex $hp 0]
2003        set port [lindex $hp 1]
2004        if [string match $port ""] {set port 80}
2005        set uri /[join [lrange $url 3 end] /]
2006        set fds [ns_sockopen -nonblock $host $port]
2007        set rfd [lindex $fds 0]
2008        set wfd [lindex $fds 1]
2009        if [catch {
2010                _http_puts $timeout $wfd "$method $uri HTTP/1.0\r"
2011                if {$rqset != ""} {
2012                        for {set i 0} {$i < [ns_set size $rqset]} {incr i} {
2013                                _http_puts $timeout $wfd \
2014                                        "[ns_set key $rqset $i]: [ns_set value $rqset $i]\r"
2015                        }
2016                } else {
2017                        _http_puts $timeout $wfd \
2018                                "Accept: */*\r"
2019
2020                        _http_puts $timeout $wfd "User-Agent: Mozilla/1.01 \[en\] (Win95; I)\r"   
2021                        _http_puts $timeout $wfd "Referer: $http_referer \r"   
2022        }
2023
2024    } errMsg] {
2025                global errorInfo
2026                #close $wfd
2027                #close $rfd
2028                if [info exists rpset] {ns_set free $rpset}
2029                return -1
2030        }
2031        return [list $rfd $wfd ""]
2032   
2033}
2034
2035
2036# httppost; give it a URL and a string with formvars, and it
2037# returns the page as a Tcl string
2038# formvars are the posted variables in the following form:
2039#        arg1=value1&arg2=value2
2040
2041# in the event of an error or timeout, -1 is returned
2042
2043proc_doc util_httppost {url formvars {timeout 30} {depth 0} {http_referer ""}} "Returns the result of POSTing to another Web server or -1 if there is an error or timeout.  formvars should be in the form \"arg1=value1&arg2=value2\"" {
2044    if [catch {
2045        if {[incr depth] > 10} {
2046                return -code error "util_httppost:  Recursive redirection:  $url"
2047        }
2048        set http [util_httpopen POST $url "" $timeout $http_referer]
2049        set rfd [lindex $http 0]
2050        set wfd [lindex $http 1]
2051
2052        #headers necesary for a post and the form variables
2053
2054        _http_puts $timeout $wfd "Content-type: application/x-www-form-urlencoded \r"
2055        _http_puts $timeout $wfd "Content-length: [string length $formvars]\r"
2056        _http_puts $timeout $wfd \r
2057        _http_puts $timeout $wfd "$formvars\r"
2058        flush $wfd
2059        close $wfd
2060
2061        set rpset [ns_set new [_http_gets $timeout $rfd]]
2062                while 1 {
2063                        set line [_http_gets $timeout $rfd]
2064                        if ![string length $line] break
2065                        ns_parseheader $rpset $line
2066                }
2067
2068
2069
2070        set headers $rpset
2071        set response [ns_set name $headers]
2072        set status [lindex $response 1]
2073        if {$status == 302} {
2074                set location [ns_set iget $headers location]
2075                if {$location != ""} {
2076                        ns_set free $headers
2077                        close $rfd
2078                        return [ns_httpget $location $timeout $depth]
2079                }
2080        }
2081        set length [ns_set iget $headers content-length]
2082        if [string match "" $length] {set length -1}
2083        set err [catch {
2084                while 1 {
2085                        set buf [_http_read $timeout $rfd $length]
2086                        append page $buf
2087                        if [string match "" $buf] break
2088                        if {$length > 0} {
2089                                incr length -[string length $buf]
2090                                if {$length <= 0} break
2091                        }
2092                }
2093        } errMsg]
2094        ns_set free $headers
2095        close $rfd
2096        if $err {
2097                global errorInfo
2098                return -code error -errorinfo $errorInfo $errMsg
2099        }
2100    } errmgs ] {return -1}
2101        return $page
2102}
2103
2104
2105proc_doc util_report_successful_library_load {{extra_message ""}} "Should be called at end of private Tcl library files so that it is easy to see in the error log whether or not private Tcl library files contain errors." {
2106    set tentative_path [info script]
2107    regsub -all {/\./} $tentative_path {/} scrubbed_path
2108    if { [string compare $extra_message ""] == 0 } {
2109        set message "Done... $scrubbed_path"
2110    } else {
2111        set message "Done... $scrubbed_path; $extra_message"
2112    }
2113    ns_log Notice $message
2114}
2115
2116proc_doc exists_and_not_null { varname } {Returns 1 if the variable name exists in the caller's environment and is not the empty string.} {
2117    upvar 1 $varname var
2118    return [expr { [info exists var] && ![empty_string_p $var] }] 
2119} 
2120
2121
2122proc_doc util_decode args {
2123    like decode in sql
2124    Takes the place of an if (or switch) statement -- convenient because it's
2125    compact and you don't have to break out of an ns_write if you're in one.
2126    args: same order as in sql: first the unknown value, then any number of
2127    pairs denoting "if the unknown value is equal to first element of pair,
2128    then return second element", then if the unknown value is not equal to any
2129    of the first elements, return the last arg
2130} {
2131    set args_length [llength $args]
2132    set unknown_value [lindex $args 0]
2133   
2134    # we want to skip the first & last values of args
2135    set counter 1
2136    while { $counter < [expr $args_length -2] } {
2137        if { [string compare $unknown_value [lindex $args $counter]] == 0 } {
2138            return [lindex $args [expr $counter + 1]]
2139        }
2140        set counter [expr $counter + 2]
2141    }
2142    return [lindex $args [expr $args_length -1]]
2143}
2144
2145proc_doc util_httpget {url {headers ""} {timeout 30} {depth 0}} "Just like ns_httpget, but first optional argument is an ns_set of headers to send during the fetch." {
2146    if {[incr depth] > 10} {
2147        return -code error "util_httpget:  Recursive redirection:  $url"
2148    }
2149    set http [ns_httpopen GET $url $headers $timeout]
2150    set rfd [lindex $http 0]
2151    close [lindex $http 1]
2152    set headers [lindex $http 2]
2153    set response [ns_set name $headers]
2154    set status [lindex $response 1]
2155    if {$status == 302} {
2156        set location [ns_set iget $headers location]
2157        if {$location != ""} {
2158            ns_set free $headers
2159            close $rfd
2160            return [ns_httpget $location $timeout $depth]
2161        }
2162    }
2163    set length [ns_set iget $headers content-length]
2164    if [string match "" $length] {set length -1}
2165    set err [catch {
2166        while 1 {
2167            set buf [_http_read $timeout $rfd $length]
2168            append page $buf
2169            if [string match "" $buf] break
2170            if {$length > 0} {
2171                incr length -[string length $buf]
2172                if {$length <= 0} break
2173            }
2174        }
2175    } errMsg]
2176    ns_set free $headers
2177    close $rfd
2178    if $err {
2179        global errorInfo
2180        return -code error -errorinfo $errorInfo $errMsg
2181    }
2182    return $page
2183}
2184
2185# some procs to make it easier to deal with CSV files (reading and writing)
2186# added by philg@mit.edu on October 30, 1999
2187
2188proc_doc util_escape_quotes_for_csv {string} "Returns its argument with double quote replaced by backslash double quote" {
2189    regsub -all {"} $string {\"}  result
2190    return $result
2191}
2192
2193proc_doc set_csv_variables_after_query {} {You can call this after an ns_db getrow or ns_db 1row to set local Tcl variables to values from the database.  You get $foo, $EQfoo (the same thing but with double quotes escaped), and $QEQQ (same thing as $EQfoo but with double quotes around the entire she-bang).} {
2194    uplevel {
2195            set set_variables_after_query_i 0
2196            set set_variables_after_query_limit [ns_set size $selection]
2197            while {$set_variables_after_query_i<$set_variables_after_query_limit} {
2198                set [ns_set key $selection $set_variables_after_query_i] [ns_set value $selection $set_variables_after_query_i]
2199                set EQ[ns_set key $selection $set_variables_after_query_i] [util_escape_quotes_for_csv [string trim [ns_set value $selection $set_variables_after_query_i]]]
2200                set QEQQ[ns_set key $selection $set_variables_after_query_i] "\"[util_escape_quotes_for_csv [string trim [ns_set value $selection $set_variables_after_query_i]]]\""
2201                incr set_variables_after_query_i
2202            }
2203    }
2204}
2205
2206#"
2207
2208proc_doc ad_page_variables {variable_specs} {
2209<pre>
2210Current syntax:
2211
2212    ad_page_variables {var_spec1 [varspec2] ... }
2213
2214    This proc handles translating form inputs into Tcl variables, and checking
2215    to see that the correct set of inputs was supplied.  Note that this is mostly a
2216    check on the proper programming of a set of pages.
2217
2218Here are the recognized var_specs:
2219
2220    variable                            ; means it's required and not null
2221    {variable default-value}
2222      Optional, with default value.  If the value is supplied but is null, and the
2223      default-value is present, that value is used.
2224    {variable -multiple-list}
2225      The value of the Tcl variable will be a list containing all of the
2226      values (in order) supplied for that form variable.  Particularly useful
2227      for collecting checkboxes or select multiples.
2228      Note that if required or optional variables are specified more than once, the
2229      first (leftmost) value is used, and the rest are ignored.
2230    {variable -array}
2231      This syntax supports the idiom of supplying multiple form variables of the
2232      same name but ending with a "_[0-9]", e.g., foo_1, foo_2.... Each value will be
2233      stored in the array variable variable with the index being whatever follows the
2234      underscore.
2235
2236There is an optional third element in the var_spec.  If it is "QQ", "qq", or
2237some variant, a variable named "QQvariable" will be created and given the
2238same value, but with single quotes escaped suitable for handing to SQL.
2239
2240Other elements of the var_spec are ignored, so a documentation string
2241describing the variable can be supplied.
2242
2243Note that the default value form will become the value form in a "set"
2244
2245Note that the default values are filled in from left to right, and can depend on
2246values of variables to their left:
2247ad_page_variables {
2248    file
2249    {start 0}
2250    {end {[expr $start + 20]}}
2251}
2252</pre>
2253} {
2254    set exception_list [list]
2255    set form [ns_getform]
2256    if { $form != "" } {
2257        set form_size [ns_set size $form]
2258        set form_counter_i 0
2259
2260        # first pass -- go through all the variables supplied in the form
2261        while {$form_counter_i<$form_size} {
2262            set variable [ns_set key $form $form_counter_i]
2263            set found "not"
2264            # find the matching variable spec, if any
2265            foreach variable_spec $variable_specs {
2266                if { [llength $variable_spec] >= 2 } {
2267                    switch -- [lindex $variable_spec 1] {
2268                        -multiple-list {
2269                            if { [lindex $variable_spec 0] == $variable } {
2270                                # variable gets a list of all the values
2271                                upvar 1 $variable var
2272                                lappend var [ns_set value $form $form_counter_i]
2273                                set found "done"
2274                                break
2275                            }
2276                        }
2277                        -array {
2278                            set varname [lindex $variable_spec 0]
2279                            set pattern "($varname)_(.+)"
2280                            if { [regexp $pattern $variable match array index] } {
2281                                if { ![empty_string_p $array] } {
2282                                    upvar 1 $array arr
2283                                    set arr($index) [ns_set value $form $form_counter_i]
2284                                }
2285                                set found "done"
2286                                break
2287                            }
2288                        }
2289                        default {
2290                            if { [lindex $variable_spec 0] == $variable } {
2291                                set found "set"
2292                                break
2293                            }
2294                        }
2295                    }
2296                } elseif { $variable_spec == $variable } {
2297                    set found "set"
2298                    break
2299                }
2300            }
2301            if { $found == "set" } {
2302                upvar 1 $variable var
2303                if { ![info exists var] } {
2304                    # take the leftmost value, if there are multiple ones
2305                    set var [ns_set value $form $form_counter_i]
2306                }
2307            }
2308            incr form_counter_i
2309        }
2310    }
2311
2312    # now make a pass over each variable spec, making sure everything required is there
2313    # and doing defaulting for unsupplied things that aren't required
2314    foreach variable_spec $variable_specs {
2315        set variable [lindex $variable_spec 0]
2316        upvar 1 $variable var
2317
2318        if { [llength $variable_spec] >= 2 } {
2319            if { ![info exists var] } {
2320                set default_value_or_flag [lindex $variable_spec 1]
2321               
2322                switch -- $default_value_or_flag {
2323                    -array {
2324                        # don't set anything
2325                    }
2326                    -multiple-list {
2327                        set var [list]
2328                    }
2329                    default {
2330                        # Needs to be set.
2331                        uplevel [list eval [list set $variable "$default_value_or_flag"]]
2332                    }
2333                }
2334            }
2335
2336            # no longer needed because we QQ everything by default now
2337            #       # if there is a QQ or qq or any variant after the var_spec,
2338            #       # make a "QQ" variable
2339            #       if { [regexp {^[Qq][Qq]$} [lindex $variable_spec 2]] && [info exists var] } {
2340            #           upvar QQ$variable QQvar
2341            #           set QQvar [DoubleApos $var]
2342            #       }
2343
2344        } else {
2345            if { ![info exists var] } {
2346                lappend exception_list "\"$variable\" required but not supplied"
2347            }
2348        }
2349
2350        # modified by rhs@mit.edu on 1/31/2000
2351        # to QQ everything by default (but not arrays)
2352        if {[info exists var] && ![array exists var]} {
2353            upvar QQ$variable QQvar
2354            set QQvar [DoubleApos $var]
2355        }
2356
2357    }
2358
2359    set n_exceptions [llength $exception_list]
2360    # this is an error in the HTML form
2361    if { $n_exceptions == 1 } {
2362        ns_returnerror 500 [lindex $exception_list 0]
2363        return -code return
2364    } elseif { $n_exceptions > 1 } {
2365        ns_returnerror 500 "<li>[join $exception_list "\n<li>"]\n"
2366        return -code return
2367    }
2368}
2369
2370proc_doc page_validation {args} {
2371    This proc allows page arg, etc. validation.  It accepts a bunch of
2372    code blocks.  Each one is executed, and any error signalled is
2373    appended to the list of exceptions.
2374    Note that you can customize the complaint page to match the design of your site,
2375    by changing the proc called to do the complaining:
2376    it's [ad_parameter ComplainProc "" ad_return_complaint]
2377
2378    The division of labor between ad_page_variables and page_validation
2379    is that ad_page_variables
2380    handles programming errors, and does simple defaulting, so that the rest of
2381    the Tcl code doesn't have to worry about testing [info exists ...] everywhere.
2382    page_validation checks for errors in user input.  For virtually all such tests,
2383    there is no distinction between "unsupplied" and "null string input".
2384
2385    Note that errors are signalled using the Tcl "error" function.  This allows
2386    nesting of procs which do the validation tests.  In addition, validation
2387    functions can return useful values, such as trimmed or otherwise munged
2388    versions of the input.
2389} {
2390    if { [info exists {%%exception_list}] } {
2391        error "Something's wrong"
2392    }
2393    # have to put this in the caller's frame, so that sub_page_validation can see it
2394    # that's because the "uplevel" used to evaluate the code blocks hides this frame
2395    upvar {%%exception_list} {%%exception_list}
2396    set {%%exception_list} [list]
2397    foreach validation_block $args {
2398        if { [catch {uplevel $validation_block} errmsg] } {
2399            lappend {%%exception_list} $errmsg
2400        }
2401    }
2402    set exception_list ${%%exception_list}
2403    unset {%%exception_list}
2404    set n_exceptions [llength $exception_list]
2405    if { $n_exceptions != 0 } {
2406        set complain_proc [ad_parameter ComplainProc "" ad_return_complaint]
2407        if { $n_exceptions == 1 } {
2408            $complain_proc $n_exceptions [lindex $exception_list 0]
2409        } else {
2410            $complain_proc $n_exceptions "<li>[join $exception_list "\n<li>"]\n"
2411        }
2412        return -code return
2413    }
2414}
2415
2416proc_doc sub_page_validation {args} {
2417    Use this inside a page_validation block which needs to check more than one thing.
2418    Put this around each part that might signal an error.
2419} {
2420    # to allow this to be at any level, we search up the stack for {%%exception_list}
2421    set depth [info level]
2422    for {set level 1} {$level <= $depth} {incr level} {
2423        upvar $level {%%exception_list} {%%exception_list}
2424        if { [info exists {%%exception_list}] } {
2425            break
2426        }
2427    }
2428    if { ![info exists {%%exception_list}] } {
2429        error "sub_page_validation not inside page_validation"
2430    }
2431    foreach validation_block $args {
2432        if { [catch {uplevel $validation_block} errmsg] } {
2433            lappend {%%exception_list} $errmsg
2434        }
2435    }
2436}
2437
2438proc_doc validate_integer {field_name string} "Throws an error if the string isn't a decimal integer; otherwise strips any leading zeros (so this won't work for octals) and returns the result." {
2439    if { ![regexp {^[0-9]+$} $string] } {
2440        error "The entry for $field_name, \"$string\" is not an integer"
2441    }
2442    # trim leading zeros, so as not to confuse Tcl
2443    set string [string trimleft $string "0"]
2444    if { [empty_string_p $string] } {
2445        # but not all of the zeros
2446        return "0"
2447    }
2448    return $string
2449}
2450
2451proc_doc validate_zip_code {field_name db zip_string country_code} "Given a string, signals an error if it's not a legal zip code" {
2452    if { $country_code == "" || [string toupper $country_code] == "US" } {
2453        if { [regexp {^[0-9][0-9][0-9][0-9][0-9](-[0-9][0-9][0-9][0-9])?$} $zip_string] } {
2454            set zip_5 [string range $zip_string 0 4]
2455            set selection [ns_db 0or1row $db "select 1 from dual where exists
2456(select 1 from zip_codes where zip_code like '$zip_5%')"]
2457            if { $selection == "" } {
2458                error "The entry for $field_name, \"$zip_string\" is not a recognized zip code"
2459            }
2460        } else {
2461            error "The entry for $field_name, \"$zip_string\" does not look like a zip code"
2462        }
2463    } else {
2464        if { $zip_string != "" } {
2465            error "Zip code is not needed outside the US"
2466        }
2467    }
2468    return $zip_string
2469}
2470
2471proc_doc validate_ad_dateentrywidget {field_name column form {allow_null 0}} {
2472} {
2473    set col [ns_urlencode $column]
2474    set day [ns_set get $form "ColValue.$col.day"]
2475    ns_set update $form "ColValue.$col.day" [string trimleft $day "0"]
2476    set month [ns_set get $form "ColValue.$col.month"]
2477    set year [ns_set get $form "ColValue.$col.year"]
2478
2479    # check that either all elements are blank
2480    # date value is formated correctly for ns_dbformvalue
2481    if { [empty_string_p "$day$month$year"] } {
2482        if { $allow_null == 0 } {
2483            error "$field_name must be supplied"
2484        } else {
2485            return ""
2486        }
2487    } elseif { ![empty_string_p $year] && [string length $year] != 4 } {
2488        error "The year must contain 4 digits."
2489    } elseif { [catch  { ns_dbformvalue $form $column date date } errmsg ] } {
2490        error "The entry for $field_name had a problem:  $errmsg."
2491    }
2492
2493    return $date
2494}
2495
2496
2497
2498proc_doc util_WriteWithExtraOutputHeaders {headers_so_far {first_part_of_page ""}} "Takes in a string of headers to write to an HTTP connection, terminated by a newline.  Checks \[ns_conn outputheaders\] and adds those headers if appropriate.  Adds two newlines at the end and writes out to the connection.  May optionally be used to write the first part of the page as well (saves a packet)" {
2499    set set_headers_i 0
2500    set set_headers_limit [ns_set size [ns_conn outputheaders]]
2501    while {$set_headers_i < $set_headers_limit} {
2502        append headers_so_far "[ns_set key [ns_conn outputheaders] $set_headers_i]: [ns_set value [ns_conn outputheaders] $set_headers_i]\n"
2503        incr set_headers_i
2504    }
2505    append entire_string_to_write $headers_so_far "\n" $first_part_of_page
2506    ns_write $entire_string_to_write
2507}
2508
2509
2510# we use this when we want to send out just the headers
2511# and then do incremental ns_writes.  This way the user
2512# doesn't have to wait like if you used a single ns_return
2513
2514proc ReturnHeaders {{content_type text/html}} {
2515    set all_the_headers "HTTP/1.0 200 OK
2516MIME-Version: 1.0
2517Content-Type: $content_type\n"
2518     util_WriteWithExtraOutputHeaders $all_the_headers
2519}
2520
2521
2522# All the following ReturnHeaders versions are obsolete;
2523# just set [ns_conn outputheaders].
2524
2525proc ReturnHeadersNoCache {{content_type text/html}} {
2526
2527    ns_write "HTTP/1.0 200 OK
2528MIME-Version: 1.0
2529Content-Type: $content_type
2530pragma: no-cache
2531
2532"
2533
2534}
2535
2536
2537proc ReturnHeadersWithCookie {cookie_content {content_type text/html}} {
2538
2539    ns_write "HTTP/1.0 200 OK
2540MIME-Version: 1.0
2541Content-Type: $content_type
2542Set-Cookie:  $cookie_content
2543
2544"
2545
2546}
2547
2548proc ReturnHeadersWithCookieNoCache {cookie_content {content_type text/html}} {
2549
2550    ns_write "HTTP/1.0 200 OK
2551MIME-Version: 1.0
2552Content-Type: $content_type
2553Set-Cookie:  $cookie_content
2554pragma: no-cache
2555
2556"
2557
2558}
2559
2560
2561proc_doc ad_return_top_of_page {first_part_of_page {content_type text/html}} "Returns HTTP headers plus the top of the user-ivisible page.  Saves a TCP packet (and therefore some overhead) compared to using ReturnHeaders and an ns_write." {
2562    set all_the_headers "HTTP/1.0 200 OK
2563MIME-Version: 1.0
2564Content-Type: $content_type\n"
2565     util_WriteWithExtraOutputHeaders $all_the_headers $first_part_of_page
2566}
2567
2568
2569
2570proc_doc apply {func arglist} {
2571    Evaluates the first argument with ARGLIST as its arguments, in the
2572    environment of its caller. Analogous to the Lisp function of the same name.
2573} {
2574    set func_and_args [concat $func $arglist]
2575    return [uplevel $func_and_args]
2576}
2577
2578proc_doc safe_eval args {
2579    Version of eval that checks its arguments for brackets that may be
2580used to execute unsafe code.
2581} {
2582    foreach arg $args {
2583        if { [regexp "\\\[" $arg] } {
2584            return -code error "Unsafe argument to safe_eval: $arg"
2585        }
2586    }
2587    return [apply uplevel $args]
2588}
2589
2590# if this hairy proc doesn't work, complain to davis@arsdigita.com
2591proc_doc util_close_html_tags {html_fragment {break_soft 0} {break_hard 0}} {
2592    Given an HTML fragment, this procedure will close any tags that
2593    have been left open.  The optional arguments let you specify that
2594    the fragment is to be truncated to a certain number of displayable
2595    characters.  After break_soft, it truncates and closes open tags unless
2596    you're within non-breaking tags (e.g., Af).  After break_hard displayable
2597    characters, the procedure simply truncates and closes any open HTML tags
2598    that might have resulted from the truncation.
2599    <p>
2600    Note that the internal syntax table dictates which tags are non-breaking.
2601    The syntax table has codes:
2602    <ul>
2603    <li>  nobr --  treat tag as nonbreaking.
2604    <li>  discard -- throws away everything until the corresponding close tag.
2605    <li>  remove -- nuke this tag and its closing tag but leave contents.
2606    <li>  close -- close this tag if left open.
2607    </ul>
2608} {
2609    set frag $html_fragment 
2610
2611    set syn(A) nobr
2612    set syn(ADDRESS) nobr
2613    set syn(NOBR) nobr
2614    #
2615    set syn(FORM) discard
2616    set syn(TABLE) discard
2617    #
2618    set syn(BLINK) remove
2619    #
2620    set syn(FONT) close
2621    set syn(B) close
2622    set syn(BIG) close
2623    set syn(I) close
2624    set syn(S) close
2625    set syn(SMALL) close
2626    set syn(STRIKE) close
2627    set syn(SUB) close
2628    set syn(SUP) close
2629    set syn(TT) close
2630    set syn(U) close
2631    set syn(ABBR) close
2632    set syn(ACRONYM) close
2633    set syn(CITE) close
2634    set syn(CODE) close
2635    set syn(DEL) close
2636    set syn(DFN) close
2637    set syn(EM) close
2638    set syn(INS) close
2639    set syn(KBD) close
2640    set syn(SAMP) close
2641    set syn(STRONG) close
2642    set syn(VAR) close
2643    set syn(DIR) close
2644    set syn(DL) close
2645    set syn(MENU) close
2646    set syn(OL) close
2647    set syn(UL) close
2648    set syn(H1) close
2649    set syn(H2) close
2650    set syn(H3) close
2651    set syn(H4) close
2652    set syn(H5) close
2653    set syn(H6) close
2654    set syn(BDO) close
2655    set syn(BLOCKQUOTE) close
2656    set syn(CENTER) close
2657    set syn(DIV) close
2658    set syn(PRE) close
2659    set syn(Q) close
2660    set syn(SPAN) close
2661
2662    set out {} 
2663    set out_len 0
2664
2665    # counts how deep we are nested in nonbreaking tags, tracks the nobr point
2666    # and what the nobr string length would be
2667    set nobr 0
2668    set nobr_out_point 0
2669    set nobr_tagptr 0
2670    set nobr_len 0
2671
2672    set discard 0
2673
2674    set tagptr -1
2675
2676    # first thing we do is chop off any trailing unclosed tag
2677    # since when we substr blobs this sometimes happens
2678   
2679    # this should in theory cut any tags which have been cut open.
2680    while {[regexp {(.*)<[^>]*$} $frag match frag]} {}
2681
2682    while { "$frag" != "" } {
2683        # here we attempt to cut the string into "pretag<TAG TAGBODY>posttag"
2684        # and build the output list.
2685
2686        if {![regexp "(\[^<]*)(<\[ \t]*(/?)(\[^ \t>]+)(\[^>]*)>)?(.*)" $frag match pretag fulltag close tag tagbody frag]} {
2687            # should never get here since above will match anything.
2688            # puts "NO MATCH: should never happen! frag=$frag"
2689            append out $frag 
2690            set frag {}
2691        } else {
2692            # puts "\n\nmatch=$match\n pretag=$pretag\n fulltag=$fulltag\n close=$close\n tag=$tag\n tagbody=$tagbody\nfrag=$frag\n\n"
2693            if { ! $discard } {
2694                # figure out if we can break with the pretag chunk
2695                if { $break_soft } {
2696                    if {! $nobr && [expr [string length $pretag] + $out_len] > $break_soft } {
2697                        # first chop pretag to the right length
2698                        set pretag [string range $pretag 0 [expr $break_soft - $out_len]]
2699                        # clip the last word
2700                        regsub "\[^ \t\n\r]*$" $pretag {} pretag
2701                        append out [string range $pretag 0 $break_soft]
2702                        break
2703                    } elseif { $nobr &&  [expr [string length $pretag] + $out_len] > $break_hard } {
2704                        # we are in a nonbreaking tag and are past the hard break
2705                        # so chop back to the point we got the nobr tag...
2706                        set tagptr $nobr_tagptr 
2707                        if { $nobr_out_point > 0 } { 
2708                            set out [string range $out 0 [expr $nobr_out_point - 1]]
2709                        } else { 
2710                            # here maybe we should decide if we should keep the tag anyway
2711                            # if zero length result would be the result...
2712                            set out {}
2713                        }
2714                        break
2715                    } 
2716                }
2717               
2718                # tack on pretag
2719                append out $pretag
2720                incr out_len [string length $pretag]
2721            }
2722           
2723            # now deal with the tag if we got one...
2724            if  { $tag == "" } { 
2725                # if the tag is empty we might have one of the bad matched that are not eating
2726                # any of the string so check for them
2727                if {[string length $match] == [string length $frag]} { 
2728                    append out $frag
2729                    set frag {}
2730                }
2731            } else {
2732                set tag [string toupper $tag]           
2733                if { ![info exists syn($tag)]} {
2734                    # if we don't have an entry in our syntax table just tack it on
2735                    # and hope for the best.
2736                    if { ! $discard } {
2737                        append  out $fulltag
2738                    }
2739                } else {
2740                    if { $close != "/" } {
2741                        # new tag
2742                        # "remove" tags are just ignored here
2743                        # discard tags
2744                        if { $discard } { 
2745                            if { $syn($tag) == "discard" } {
2746                                incr discard
2747                                incr tagptr
2748                                set tagstack($tagptr) $tag
2749                            }
2750                        } else {
2751                            switch $syn($tag) {
2752                                nobr { 
2753                                    if { ! $nobr } {
2754                                        set nobr_out_point [string length $out]
2755                                        set nobr_tagptr $tagptr
2756                                        set nobr_len $out_len
2757                                    }
2758                                    incr nobr
2759                                    incr tagptr
2760                                    set tagstack($tagptr) $tag
2761                                    append out $fulltag
2762                                }
2763                                discard { 
2764                                    incr discard
2765                                    incr tagptr
2766                                    set tagstack($tagptr) $tag
2767                                }
2768                                close {                                 
2769                                    incr tagptr
2770                                    set tagstack($tagptr) $tag
2771                                    append out $fulltag
2772                                }
2773                            }
2774                        }
2775                    } else { 
2776                        # we got a close tag
2777                        if { $discard } { 
2778                            # if we are in discard mode only watch for
2779                            # closes to discarded tags
2780                            if { $syn($tag) == "discard"} {
2781                                if {$tagptr > -1} {
2782                                    if { $tag != $tagstack($tagptr) } {
2783                                        #puts "/$tag without $tag"
2784                                    } else {
2785                                        incr tagptr -1
2786                                        incr discard -1
2787                                    }
2788                                }
2789                            }
2790                        } else {
2791                            if { $syn($tag) != "remove"} {
2792                                # if tag is a remove tag we just ignore it...
2793                                if {$tagptr > -1} {
2794                                    if {$tag != $tagstack($tagptr) } {
2795                                        # puts "/$tag without $tag"
2796                                    } else {
2797                                        incr tagptr -1
2798                                        if { $syn($tag) == "nobr"} {
2799                                            incr nobr -1
2800                                        } 
2801                                        append out $fulltag
2802                                    }
2803                                }
2804                            }
2805                        }
2806                    }
2807                }
2808            }
2809        }
2810    }
2811   
2812    # on exit of the look either we parsed it all or we truncated.
2813    # we should now walk the stack and close any open tags.
2814
2815    for {set i $tagptr} { $i > -1 } {incr i -1} { 
2816        # append out "<!-- autoclose --> </$tagstack($i)>"
2817        append out "</$tagstack($i)>"
2818    }
2819   
2820    return $out
2821}
2822
2823
2824ad_proc util_dbq {
2825    { 
2826        -null_is_null_p f
2827    }
2828    vars
2829} {
2830    Given a list of variable names this routine
2831    creates variables named DBQvariable_name which can be used in 
2832    sql insert and update statements. 
2833    <p>
2834    If -null_is_null_p is t then we return the string "null" unquoted
2835    so that "update foo set var = $DBQvar where ..." will do what we want
2836    if we default var to "null".
2837} {
2838    foreach var $vars {
2839        upvar 1 $var val
2840        if [info exists val] {
2841            if { $null_is_null_p == "t" 
2842                 && $val == {null} } {
2843                uplevel [list set DBQ$var {null}]
2844            } else {
2845                uplevel [list set DBQ$var "'[DoubleApos [string trim $val]]'"]
2846            }
2847        }
2848    }
2849}
2850
2851proc_doc ad_decode { args } "this procedure is analogus to sql decode procedure. first parameter is the value we want to decode. this parameter is followed by a list of pairs where first element in the pair is convert from value and second element is convert to value. last value is default value, which will be returned in the case convert from values matches the given value to be decoded" {
2852    set num_args [llength $args]
2853    set input_value [lindex $args 0]
2854
2855    set counter 1
2856
2857    while { $counter < [expr $num_args - 2] } {
2858        lappend from_list [lindex $args $counter]
2859        incr counter
2860        lappend to_list [lindex $args $counter]
2861        incr counter
2862    }
2863
2864    set default_value [lindex $args $counter]
2865
2866    if { $counter < 2 } {
2867        return $default_value
2868    }
2869
2870    set index [lsearch -exact $from_list $input_value]
2871   
2872    if { $index < 0 } {
2873        return $default_value
2874    } else {
2875        return [lindex $to_list $index]
2876    }
2877}
2878
2879proc_doc ad_urlencode { string } "same as ad_urlencode except that dash and underscore are left unencoded." {
2880    set encoded_string [ns_urlencode $string]
2881    regsub -all {%2d} $encoded_string {-} encoded_string
2882    regsub -all {%5f} $encoded_string {_} ad_encoded_string
2883    return $ad_encoded_string
2884}
2885
2886util_report_successful_library_load
2887
2888# The remainder of the file was merged from:
2889#
2890# /tcl/000-aolserver-3-specific.tcl
2891#
2892# It defines procs that one only needs for AOLserver 3.0 (necessitated
2893# by the fact that most of our code base comes from AOLserver 1.x and
2894# 2.x.
2895#
2896# This section was put together by markd@arsdigita.com
2897
2898if [util_aolserver_2_p] {
2899    # Nothing below is needed by AOLserver 2.x, so bail out
2900    return
2901} else {
2902    ns_log Notice "00-ad-utilities.tcl loading procs for AOLserver 2.x compatibility" 
2903}
2904
2905# these were mostly stolen from various places the AOLserver 2.3.3 release
2906
2907# ns_dbquotename:
2908#
2909# If name contains a space, then it is surrounded by double quotes.
2910# This is useful for names in SQL statements that may contain spaces.
2911
2912proc ns_dbquotename {name} {
2913    if [regexp " " $name] {
2914        return "\"$name\""
2915    } else {
2916        return $name
2917    }   
2918}
2919
2920# ns_dbquotevalue:
2921#
2922# Prepares a value string for inclusion in an SQL statement.
2923# "" is translated into NULL.
2924# All values of any numeric type are left alone.
2925# All other values are surrounded by single quotes and any
2926# single quotes included in the value are escaped (ie. translated
2927# into 2 single quotes).
2928
2929proc ns_dbquotevalue {value {type text}} {
2930
2931    if [string match $value ""] {
2932        return "NULL"
2933    }
2934
2935    if {$type == "decimal" \
2936            || $type == "double" \
2937            || $type == "integer" \
2938            || $type == "int" \
2939            || $type == "real" \
2940            || $type == "smallint" \
2941            || $type == "bigint" \
2942            || $type == "bit" \
2943            || $type == "float" \
2944            || $type == "numeric" \
2945            || $type == "tinyint"} {
2946        return $value
2947    }
2948    regsub -all "'" $value "''" value
2949    return "'$value'"
2950}
2951
2952
2953
2954# -1 = Not there or value was ""
2955#  0 = NULL, set value to NULL.
2956#  1 = Got value, set value to it.
2957
2958proc ns_dbformvalue {formdata column type valuebyref} {
2959
2960    upvar $valuebyref value
2961
2962    if {[ns_set get $formdata ColValue.[ns_urlencode $column].NULL] == "t"} {
2963        set value ""
2964        return 0
2965    }
2966
2967    set value [ns_set get $formdata ColValue.[ns_urlencode $column]]
2968
2969    if [string match $value ""] {
2970        switch $type {
2971           
2972            date      {
2973                set value [ns_buildsqldate \
2974                        [ns_set get $formdata ColValue.[ns_urlencode $column].month] \
2975                        [ns_set get $formdata ColValue.[ns_urlencode $column].day] \
2976                        [ns_set get $formdata ColValue.[ns_urlencode $column].year]]
2977            }
2978           
2979            time      {
2980                set value [ns_buildsqltime \
2981                        [ns_set get $formdata ColValue.[ns_urlencode $column].time] \
2982                        [ns_set get $formdata ColValue.[ns_urlencode $column].ampm]]
2983            }
2984           
2985            datetime  -
2986            timestamp {
2987                set value [ns_buildsqltimestamp \
2988                        [ns_set get $formdata ColValue.[ns_urlencode $column].month] \
2989                        [ns_set get $formdata ColValue.[ns_urlencode $column].day] \
2990                        [ns_set get $formdata ColValue.[ns_urlencode $column].year] \
2991                        [ns_set get $formdata ColValue.[ns_urlencode $column].time] \
2992                        [ns_set get $formdata ColValue.[ns_urlencode $column].ampm]]
2993            }
2994           
2995            default {
2996            }
2997        }
2998    }
2999    if [string match $value ""] {
3000        return -1
3001    } else {
3002        return 1
3003    }
3004}
3005
3006proc ns_dbformvalueput {htmlform column type value} {
3007
3008    switch $type {
3009
3010        date {
3011            set retval [ns_formvalueput $htmlform ColValue.[ns_urlencode $column].NULL f]
3012            set retval [ns_formvalueput $retval ColValue.[ns_urlencode $column].month \
3013                    [ns_parsesqldate month $value]]
3014            set retval [ns_formvalueput $retval ColValue.[ns_urlencode $column].day \
3015                    [ns_parsesqldate day $value]]
3016            set retval [ns_formvalueput $retval ColValue.[ns_urlencode $column].year \
3017                    [ns_parsesqldate year $value]]
3018        }
3019
3020        time {
3021            set retval [ns_formvalueput $htmlform ColValue.[ns_urlencode $column].NULL f]
3022            set retval [ns_formvalueput $retval ColValue.[ns_urlencode $column].time \
3023                    [ns_parsesqltime time $value]]
3024            set retval [ns_formvalueput $retval ColValue.[ns_urlencode $column].ampm \
3025                    [ns_parsesqltime ampm $value]]
3026
3027        }
3028
3029        datetime  -
3030        timestamp {
3031            set retval [ns_formvalueput $htmlform ColValue.[ns_urlencode $column].NULL f]
3032            set retval [ns_formvalueput $retval ColValue.[ns_urlencode $column].month \
3033                    [ns_parsesqltimestamp month $value]]
3034            set retval [ns_formvalueput $retval ColValue.[ns_urlencode $column].day \
3035                    [ns_parsesqltimestamp day $value]]
3036            set retval [ns_formvalueput $retval ColValue.[ns_urlencode $column].year \
3037                    [ns_parsesqltimestamp year $value]]
3038            set retval [ns_formvalueput $retval ColValue.[ns_urlencode $column].time \
3039                    [ns_parsesqltimestamp time $value]]
3040            set retval [ns_formvalueput $retval ColValue.[ns_urlencode $column].ampm \
3041                    [ns_parsesqltimestamp ampm $value]]
3042           
3043        }
3044
3045        default {
3046
3047            set retval [ns_formvalueput $htmlform ColValue.[ns_urlencode $column] $value]
3048        }
3049    }
3050    return $retval
3051}
3052
3053# Special thanks to Brian Tivol at Hearst New Media Center and MIT
3054# for providing the core of this code.
3055
3056proc ns_formvalueput {htmlpiece dataname datavalue} {
3057
3058    set newhtml ""
3059
3060    while {$htmlpiece != ""} {
3061        if {[string index $htmlpiece 0] == "<"} {
3062            regexp {<([^>]*)>(.*)} $htmlpiece m tag htmlpiece
3063            set tag [string trim $tag]
3064            set CAPTAG [string toupper $tag]
3065
3066            switch -regexp $CAPTAG {
3067
3068                {^INPUT} {
3069                    if {[regexp {TYPE=("IMAGE"|"SUBMIT"|"RESET"|IMAGE|SUBMIT|RESET)} $CAPTAG]} {
3070                        append newhtml <$tag>
3071                       
3072                    } elseif {[regexp {TYPE=("CHECKBOX"|CHECKBOX|"RADIO"|RADIO)} $CAPTAG]} {
3073                       
3074                        set name [ns_tagelement $tag NAME]
3075
3076                        if {$name == $dataname} {
3077
3078                            set value [ns_tagelement $tag VALUE]
3079
3080                            regsub -all -nocase { *CHECKED} $tag {} tag
3081
3082                            if {$value == $datavalue} {
3083                                append tag " CHECKED"
3084                            }
3085                        }
3086                        append newhtml <$tag>
3087
3088                    } else {
3089
3090                        ## If it's an INPUT TYPE that hasn't been covered
3091                        #  (text, password, hidden, other (defaults to text))
3092                        ## then we add/replace the VALUE tag
3093                       
3094                        set name [ns_tagelement $tag NAME]
3095                       
3096                        if {$name == $dataname} {
3097                            ns_tagelementset tag VALUE $datavalue
3098                        }
3099                        append newhtml <$tag>
3100                    }
3101                }
3102
3103                {^TEXTAREA} {
3104
3105                    ###
3106                    #   Fill in the middle of this tag
3107                    ###
3108
3109                    set name [ns_tagelement $tag NAME]
3110                   
3111                    if {$name == $dataname} {
3112                        while {![regexp -nocase {^<( *)/TEXTAREA} $htmlpiece]} {
3113                            regexp {^.[^<]*(.*)} $htmlpiece m htmlpiece
3114                        }
3115                        append newhtml <$tag>$datavalue
3116                    } else {
3117                        append newhtml <$tag>
3118                    }
3119                }
3120               
3121                {^SELECT} {
3122
3123                    ### Set flags so OPTION and /SELECT know what to look for:
3124                    #   snam is the variable name, sflg is 1 if nothing's
3125                    ### been added, smul is 1 if it's MULTIPLE selection
3126
3127
3128                    if {[ns_tagelement $tag NAME] == $dataname} {
3129                        set inkeyselect 1
3130                        set addoption 1
3131                    } else {
3132                        set inkeyselect 0
3133                        set addoption 0
3134                    }
3135
3136                    append newhtml <$tag>
3137                }
3138
3139                {^OPTION} {
3140                   
3141                    ###
3142                    #   Find the value for this
3143                    ###
3144
3145                    if {$inkeyselect} {
3146
3147                        regsub -all -nocase { *SELECTED} $tag {} tag
3148
3149                        set value [ns_tagelement $tag VALUE]
3150
3151                        regexp {^([^<]*)(.*)} $htmlpiece m txt htmlpiece
3152
3153                        if [string match "" $value] {
3154                            set value [string trim $txt]
3155                        }
3156
3157                        if {$value == $datavalue} {
3158                            append tag " SELECTED"
3159                            set addoption 0
3160                        }
3161                        append newhtml <$tag>$txt
3162                    } else {
3163                        append newhtml <$tag>
3164                    }
3165                }
3166
3167                {^/SELECT} {
3168                   
3169                    ###
3170                    #   Do we need to add to the end?
3171                    ###
3172                   
3173                    if {$inkeyselect && $addoption} {
3174                        append newhtml "<option selected>$datavalue<$tag>"
3175                    } else {
3176                        append newhtml <$tag>
3177                    }
3178                    set inkeyselect 0
3179                    set addoption 0
3180                }
3181               
3182                {default} {
3183                    append newhtml <$tag>
3184                }
3185            }
3186
3187        } else {
3188            regexp {([^<]*)(.*)} $htmlpiece m brandnew htmlpiece
3189            append newhtml $brandnew
3190        }
3191    }
3192    return $newhtml
3193}
3194
3195proc ns_tagelement {tag key} {
3196    set qq {"([^"]*)"}                ; # Matches what's in quotes
3197    set pp {([^ >]*)}                 ; # Matches a word (mind yer pp and qq)
3198   
3199    if {[regexp -nocase "$key *= *$qq" $tag m name]} {}\
3200            elseif {[regexp -nocase "$key *= *$pp" $tag m name]} {}\
3201            else {set name ""}
3202    return $name
3203}
3204
3205
3206# Assumes that the final ">" in the tag has been removed, and
3207# leaves it removed
3208
3209proc ns_tagelementset {tagvar key value} {
3210
3211    upvar $tagvar tag
3212
3213    set qq {"([^"]*)"}                ; # Matches what's in quotes
3214    set pp {([^ >]*)}                 ; # Matches a word (mind yer pp and qq)
3215   
3216    regsub -all -nocase "$key=$qq" $tag {} tag
3217    regsub -all -nocase "$key *= *$pp" $tag {} tag
3218    append tag " value=\"$value\""
3219}
3220
3221
3222
3223
3224# sorts a list of pairs based on the first value in each pair
3225
3226proc _ns_paircmp {pair1 pair2} {
3227    if {[lindex $pair1 0] > [lindex $pair2 0]} {
3228        return 1
3229    } elseif {[lindex $pair1 0] < [lindex $pair2 0]} {
3230        return -1
3231    } else {
3232        return 0
3233    }
3234}
3235
3236# ns_htmlselect ?-multi? ?-sort? ?-labels labels? key values ?selecteddata?
3237
3238proc ns_htmlselect args {
3239
3240    set multi 0
3241    set sort 0
3242    set labels {}
3243    while {[string index [lindex $args 0] 0] == "-"} {
3244        if {[lindex $args 0] == "-multi"} {
3245            set multi 1
3246            set args [lreplace $args 0 0]
3247        }
3248        if {[lindex $args 0] == "-sort"} {
3249            set sort 1
3250            set args [lreplace $args 0 0]
3251        }
3252        if {[lindex $args 0] == "-labels"} {
3253            set labels [lindex $args 1]
3254            set args [lreplace $args 0 1]
3255        }
3256    }
3257   
3258    set key [lindex $args 0]
3259    set values [lindex $args 1]
3260   
3261    if {[llength $args] == 3} {
3262        set selecteddata [lindex $args 2]
3263    } else {
3264        set selecteddata ""
3265    }
3266   
3267    set select "<SELECT NAME=$key"
3268    if {$multi == 1} {
3269        set size [llength $values]
3270        if {$size > 5} {
3271            set size 5
3272        }
3273        append select " MULTIPLE SIZE=$size"
3274    } else {
3275        if {[llength $values] > 25} {
3276            append select " SIZE=5"
3277        }
3278    }
3279    append select ">\n"
3280    set len [llength $values]
3281    set lvpairs {}
3282    for {set i 0} {$i < $len} {incr i} {
3283        if [string match "" $labels] {
3284            set label [lindex $values $i]
3285        } else {
3286            set label [lindex $labels $i]
3287        }
3288        regsub -all "\"" $label "" label
3289        lappend lvpairs [list  $label [lindex $values $i]]
3290    }
3291    if $sort {
3292        set lvpairs [lsort -command _ns_paircmp -increasing $lvpairs]
3293    }
3294    foreach lvpair $lvpairs {
3295        append select "<OPTION VALUE=\"[lindex $lvpair 1]\""
3296        if {[lsearch $selecteddata [lindex $lvpair 1]] >= 0} {
3297            append select " SELECTED"
3298        }
3299        append select ">[lindex $lvpair 0]\n"
3300    }
3301    append select "</SELECT>"
3302
3303    return $select
3304}
3305
3306proc ns_setexpires args {
3307    # skip over the optional connId parameter: just use the last arg
3308    set secondsarg [expr [llength $args] - 1]
3309
3310    ns_set update [ns_conn outputheaders] Expires \
3311            [ns_httptime [expr [lindex $args $secondsarg] + [ns_time]]]
3312}
3313
3314proc ns_browsermatch args {
3315    # skip over the optional connId parameter: just use the last arg
3316    set globarg [expr [llength $args] - 1]
3317
3318    return [string match [lindex $args $globarg]  \
3319            [ns_set iget [ns_conn headers] user-agent]]
3320}
3321
3322proc ns_set_precision {precision} {
3323    global tcl_precision
3324    set tcl_precision $precision
3325}
3326
3327proc ns_updateheader {key value} {
3328    ns_set update [ns_conn outputheaders] $key $value
3329}
3330
3331ns_share NS
3332set NS(months) [list January February March April May June \
3333        July August September October November December]
3334
3335proc ns_localsqltimestamp {} {
3336    set time [ns_localtime]
3337
3338    return [format "%04d-%02d-%02d %02d:%02d:%02d" \
3339            [expr [ns_parsetime year $time] + 1900] \
3340            [expr [ns_parsetime mon $time] + 1] \
3341            [ns_parsetime mday $time] \
3342            [ns_parsetime hour $time] \
3343            [ns_parsetime min $time] \
3344            [ns_parsetime sec $time]]
3345}
3346
3347proc ns_parsesqldate {opt sqldate} {
3348    ns_share NS
3349    scan $sqldate "%04d-%02d-%02d" year month day
3350
3351    switch $opt {
3352        month {return [lindex $NS(months) [expr $month - 1]]}
3353        day {return $day}
3354        year {return $year}
3355        default {error "Unknown option \"$opt\": should be year, month or day"}
3356    }
3357}
3358   
3359proc ns_parsesqltime {opt sqltime} {
3360
3361    if {[scan $sqltime "%02d:%02d:%02d" hours minutes seconds] == 2} {
3362        set seconds 0
3363    }
3364
3365    switch $opt {
3366        time {
3367            if {$hours == 0} {
3368                set hours 12
3369            } elseif {$hours > 12} {
3370                set hours [incr hours -12]
3371            }
3372            if {$seconds == 0} {
3373                return [format "%d:%02d" $hours $minutes]
3374            } else {
3375                return [format "%d:%02d:%02d" $hours $minutes $seconds]
3376            }
3377        }
3378        ampm {
3379            if {$hours < 12} {
3380                return AM
3381            } else {
3382                return PM
3383            }
3384        }
3385
3386        default {error "Unknown command \"$opt\": should be time or ampm"}
3387    }
3388}
3389
3390proc ns_parsesqltimestamp {opt sqltimestamp} {
3391
3392    switch $opt {
3393        month -
3394        day -
3395        year {return [ns_parsesqldate $opt [lindex [split $sqltimestamp " "] 0]]}
3396        time -
3397        ampm {return [ns_parsesqltime $opt [lindex [split $sqltimestamp " "] 1]]}
3398        default {error "Unknown command \"$opt\": should be month, day, year, time or ampm"}
3399    }
3400}
3401
3402proc ns_buildsqltime {time ampm} {
3403
3404    if {[string match "" $time] && [string match "" $ampm]} {
3405        return ""
3406    }
3407
3408    if {[string match "" $time] || [string match "" $ampm]} {
3409        error "Invalid time: $time $ampm"
3410    }
3411    set seconds 0
3412    set num [scan $time "%d:%d:%d" hours minutes seconds]
3413
3414    if {$num < 2 || $num > 3 \
3415            || $hours < 1 || $hours > 12 \
3416            || $minutes < 0 || $minutes > 59 \
3417            || $seconds < 0 || $seconds > 61} {
3418        error "Invalid time: $time $ampm"
3419    }
3420
3421    if {$ampm == "AM"} {
3422        if {$hours == 12} {
3423            set hours 0
3424        }
3425    } elseif {$ampm == "PM"} {
3426        if {$hours != 12} {
3427            incr hours 12
3428        }
3429    } else {
3430        error "Invalid time: $time $ampm"
3431    }
3432
3433    return [format  "%02d:%02d:%02d" $hours $minutes $seconds]
3434}
3435
3436proc ns_buildsqldate {month day year} {
3437    ns_share NS
3438
3439    if {[string match "" $month] \
3440            && [string match "" $day] \
3441            && [string match "" $year]} {
3442        return ""
3443    }
3444
3445    if {![ns_issmallint $month]} {
3446        set month [expr [lsearch $NS(months) $month] + 1]
3447    }
3448
3449    if {[string match "" $month] \
3450            || [string match "" $day] \
3451            || [string match "" $year] \
3452            || $month < 1 || $month > 12 \
3453            || $day < 1 || $day > 31 \
3454            || $year < 1\
3455            || ($month == 2 && $day > 29)\
3456            || (($year % 4) != 0 && $month == 2 && $day > 28) \
3457            || ($month == 4 && $day > 30)\
3458            || ($month == 6 && $day > 30)\
3459            || ($month == 9 && $day > 30)\
3460            || ($month == 11 && $day > 30) } {
3461        error "Invalid date: $month $day $year"
3462    }
3463
3464    return [format "%04d-%02d-%02d" $year $month $day]
3465}
3466
3467proc ns_buildsqltimestamp {month day year time ampm} {
3468    set date [ns_buildsqldate $month $day $year]
3469    set time [ns_buildsqltime $time $ampm]
3470
3471    if {[string match "" $date] || [string match "" $time]} {
3472        return ""
3473    }
3474
3475    return "$date $time"
3476}
3477
3478# ns_localtime returns a time as a list of elements, and ns_parsetime
3479# returns one of those elements
3480
3481proc ns_parsetime {option time} {
3482    set parts {sec min hour mday mon year wday yday isdst}
3483    set pos [lsearch $parts $option]
3484    if {$pos == -1} {
3485        error "Incorrect option to ns_parsetime: \"$option\" Should be\
3486               one of \"$parts\""
3487    }
3488    return [lindex $time $pos]
3489}
3490
3491# ns_findset returns a set with a given name from a list.
3492
3493proc ns_findset {sets name} {
3494    foreach set $sets {
3495        if {[ns_set name $set] == $name} {
3496            return $set
3497        }
3498    }
3499    return ""
3500}
3501
3502# getformdata - make sure an HTML FORM was sent with the request.
3503proc getformdata {conn formVar} {
3504        upvar $formVar form
3505        set form [ns_conn form $conn]
3506        if [string match "" $form] {
3507                ns_returnbadrequest $conn "Missing HTML FORM data"
3508                return 0
3509        }
3510        return 1
3511}
3512
3513proc ns_paren {val} {
3514    if {$val != ""} {
3515        return "($val)"
3516    } else {
3517        return ""
3518    }
3519}
3520
3521proc Paren {val} {
3522    return [ns_paren $val]
3523}
3524
3525proc issmallint {value} {
3526    return [ns_issmallint $value]
3527}
3528
3529proc ns_issmallint {value} {
3530    return [expr [regexp {^[0-9]+$} $value] && [string length $value] <= 6]
3531}
3532
3533proc _ns_updatebutton {db table var} {
3534    upvar $var updatebutton
3535
3536    if ![info exists updatebutton] {
3537        set updatebutton ""
3538    }
3539    if [string match "" $updatebutton] {
3540        set updatebutton [ns_table value $db $table update_button_label]
3541    }
3542    if [string match "" $updatebutton] {
3543        set updatebutton "Update Record"
3544    }
3545}
3546
3547proc ns_findrowbyid {db table rowidset} {
3548
3549    set sql "select * from [ns_dbquotename $table] where"
3550    for {set i 0} {$i < [ns_set size $rowidset]} {incr i} {
3551        if {$i != 0} {
3552            append sql " and"
3553        }
3554        set column [ns_urldecode [ns_set key $rowidset $i]]
3555        set value [ns_set value $rowidset $i]
3556        set type [ns_column type $db $table $column]
3557        append sql " [ns_dbquotename $column] = [ns_dbquotevalue $value $type]"
3558    }
3559    if [catch {
3560        set row [ns_db 1row $db $sql]
3561    } errMsg] {
3562        ns_db setexception $db NSINT "Could not find row"
3563        error $errMsg
3564    }
3565    return $row
3566}
3567
3568proc ns_sourceproc {conn ignored} {
3569        set script [ns_url2file [ns_conn url $conn]]
3570        if ![file exists $script] {
3571                ns_returnnotfound $conn
3572        } else {
3573                source $script
3574        }
3575}
3576
3577proc ns_putscript {conn ignored} {
3578        ns_returnbadrequest $conn "Cannot PUT a script file"
3579}
3580
3581# open a file with exclusive rights.  This call can fail (if you
3582# try to open-create-exclusive and the file already exists).  If this
3583# happens, "" is returned, in which case you need to generate a new
3584# name and try again
3585proc ns_openexcl {file} {
3586
3587    if [catch { set fp [open $file {RDWR CREAT EXCL} ] } err] {
3588
3589        global errorCode
3590
3591        if { [lindex $errorCode 1] != "EEXIST"} {
3592            return -code error $err
3593        }
3594
3595        return ""
3596    }
3597
3598    return $fp
3599
3600}
3601
3602proc _http_read {timeout sock length} {
3603
3604    return [_ns_http_read $timeout $sock $length]
3605
3606} ;# _http_read
3607
3608
3609
3610# tcl page support
3611
3612set tcl_pages_enabled [ns_config -bool ns/server/[ns_info server] EnableTclPages]
3613
3614if {$tcl_pages_enabled == "1"} {
3615    ns_register_proc GET /*.tcl ns_sourceproc
3616    ns_register_proc POST /*.tcl ns_sourceproc
3617    ns_register_proc HEAD /*.tcl ns_sourceproc
3618    ns_register_proc PUT /*.tcl ns_putscript
3619}
3620
3621proc ns_sourceproc {conn ignored} {
3622        set script [ns_url2file [ns_conn url $conn]]
3623        if ![file exists $script] {
3624                ns_returnnotfound $conn
3625        } else {
3626                source $script
3627        }
3628}
3629
3630proc ns_putscript {conn ignored} {
3631        ns_returnbadrequest $conn "Cannot PUT a script file"
3632}
3633
3634proc _ns_dateentrywidget {column} {
3635    ns_share NS
3636
3637    set output "<SELECT name=ColValue.[ns_urlencode $column].month>\n"
3638    for {set i 0} {$i < 12} {incr i} {
3639        append output "<OPTION> [lindex $NS(months) $i]\n"
3640    }
3641
3642    append output \
3643"</SELECT>&nbsp;<INPUT NAME=ColValue.[ns_urlencode $column].day\
3644TYPE=text SIZE=3 MAXLENGTH=2>&nbsp;<INPUT NAME=ColValue.[ns_urlencode $column].year\
3645TYPE=text SIZE=5 MAXLENGTH=4>"
3646
3647    return [ns_dbformvalueput $output $column date [lindex [split [ns_localsqltimestamp] " "] 0]]
3648}
3649
3650proc _ns_timeentrywidget {column} {
3651   
3652    set output "<INPUT NAME=ColValue.[ns_urlencode $column].time TYPE=text SIZE=9>&nbsp;<SELECT NAME=ColValue.[ns_urlencode $column].ampm>
3653<OPTION> AM
3654<OPTION> PM
3655</SELECT>"
3656
3657    return [ns_dbformvalueput $output $column time [lindex [split [ns_localsqltimestamp] " "] 1]]
3658}
3659
3660
3661
Note: See TracBrowser for help on using the repository browser.