-
Notifications
You must be signed in to change notification settings - Fork 19
/
utilities-procs.tcl
5208 lines (4403 loc) · 168 KB
/
utilities-procs.tcl
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
ad_library {
Provides a variety of non-ACS-specific utilities, including
the procs to support the who's online feature.
@author Various (acs@arsdigita.com)
@creation-date 13 April 2000
@cvs-id $Id$
}
namespace eval util {}
ad_proc util::zip {
-source:required
-destination:required
} {
Create a zip file.
@param source is the content to be zipped. If it is a directory, archive will
contain all files into directory without the trailing directory itself.
@param destination is the name of the created file
} {
set zip [util::which zip]
if {$zip eq ""} {
error "zip command not found on the system."
}
set cmd [list exec]
switch $::tcl_platform(platform) {
windows {lappend cmd cmd.exe /c}
default {lappend cmd bash -c}
}
if {[file isfile $source]} {
set filename [file tail $source]
set in_path [file dirname $source]
} else {
set filename "."
set in_path $source
}
# To avoid having the full path of the file included in the archive,
# we must first cd to the source directory. zip doesn't have an option
# to do this without building a little script...
set zip_cmd [list]
lappend zip_cmd "cd $in_path"
lappend zip_cmd "${zip} -r \"${destination}\" \"${filename}\""
set zip_cmd [join $zip_cmd " && "]
lappend cmd $zip_cmd
# create the archive
{*}$cmd
}
ad_proc util::unzip {
-source:required
-destination:required
-overwrite:boolean
} {
@param source must be the name of a valid zip file to be decompressed
@param destination must be the name of a valid directory to contain decompressed files
} {
set unzip [util::which unzip]
if {$unzip eq ""} {error "unzip command not found on the system."}
# -n means we don't overwrite existing files
set cmd [list exec $unzip]
if {$overwrite_p} {lappend cmd -o
} else {lappend cmd -n}
lappend cmd $source -d $destination
{*}$cmd
}
# Let's define the nsv arrays out here, so we can call nsv_exists
# on their keys without checking to see if it already exists.
# we create the array by setting a bogus key.
proc proc_source_file_full_path {proc_name} {
if { ![nsv_exists proc_source_file $proc_name] } {
return ""
} else {
set tentative_path [nsv_get proc_source_file $proc_name]
regsub -all {/\./} $tentative_path {/} result
return $result
}
}
ad_proc 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.
} {
set tentative_path [info script]
regsub -all {/\./} $tentative_path {/} scrubbed_path
if { $extra_message eq "" } {
set message "Loading $scrubbed_path"
} else {
set message "Loading $scrubbed_path; $extra_message"
}
ns_log Notice $message
}
ad_proc check_for_form_variable_naughtiness {
name
value
} {
stuff to process the data that comes
back from the users
if the form looked like
<input type=text name=yow> and <input type=text name=bar>
then after you run this function you'll have Tcl vars
$foo and $bar set to whatever the user typed in the form
this uses the initially nauseating but ultimately delicious
Tcl system function "uplevel" that lets a subroutine bash
the environment and local vars of its caller. It ain't Common Lisp...
This is an ad-hoc check to make sure users aren't trying to pass in
"naughty" form variables in an effort to hack the database by passing
in SQL. It is called in all instances where a Tcl variable
is set from a form variable.
Checks the given variable for against known form variable exploits.
If it finds anything objectionable, it throws an error.
} {
# security patch contributed by michael@cleverly.com
if { [string match "QQ*" $name] } {
error "Form variables should never begin with QQ!"
}
# contributed by michael@cleverly.com
if { "Vform_counter_i" eq $name } {
error "Vform_counter_i not an allowed form variable"
}
# The statements below make ACS more secure, because it prevents
# overwrite of variables from something like set_the_usual_form_variables
# and it will be better if it was in the system. Yet, it is commented
# out because it will cause an unstable release. To add this security
# feature, we will need to go through all the code in the ACS and make
# sure that the code doesn't try to overwrite intentionally and also
# check to make sure that when Tcl files are sourced from another proc,
# the appropriate variables are unset. If you want to install this
# security feature, then you can look in the release notes for more info.
#
# security patch contributed by michael@cleverly.com,
# fixed by iwashima@arsdigita.com
#
# upvar 1 $name name_before
# if { [info exists name_before] } {
# The variable was set before the proc was called, and the
# form attempts to overwrite it
# error "Setting the variables from the form attempted to overwrite existing variable $name"
# }
# no naughtiness with uploaded files (discovered by ben@mit.edu)
# patch by richardl@arsdigita.com, with no thanks to
# jsc@arsdigita.com.
if { [string match "*tmpfile" $name] } {
set tmp_filename [ns_queryget $name]
# ensure no .. in the path
ns_normalizepath $tmp_filename
set passed_check_p 0
# check to make sure path is to an authorized directory
set tmpdir_list [ad_parameter_all_values_as_list -package_id [ad_conn subsite_id] TmpDir]
if { $tmpdir_list eq "" } {
set tmpdir_list [list [ns_config ns/parameters tmpdir] "/var/tmp" "/tmp"]
}
foreach tmpdir $tmpdir_list {
if { [string match "$tmpdir*" $tmp_filename] } {
set passed_check_p 1
break
}
}
if { !$passed_check_p } {
error "You specified a path to a file that is not allowed on the system!"
}
}
# integrates with the ad_set_typed_form_variable_filter system
# written by dvr@arsdigita.com
# see if this is one of the typed variables
global ad_typed_form_variables
if { [info exists ad_typed_form_variables] } {
foreach typed_var_spec $ad_typed_form_variables {
set typed_var_name [lindex $typed_var_spec 0]
if { ![string match $typed_var_name $name] } {
# no match. Go to the next variable in the list
continue
}
# the variable matched the pattern
set typed_var_type [lindex $typed_var_spec 1]
if { "" eq $typed_var_type } {
# if they don't specify a type, the default is 'integer'
set typed_var_type integer
}
set variable_safe_p [ad_var_type_check_${typed_var_type}_p $value]
if { !$variable_safe_p } {
ns_returnerror 500 "variable $name failed '$typed_var_type' type check"
ns_log Error "check_for_form_variable_naughtiness: [ad_conn url] called with \$$name = $value"
error "variable $name failed '$typed_var_type' type check"
}
# we've found the first element in the list that matches,
# and we don't want to check against any others
break
}
}
}
ad_proc -private DoubleApos {string} {
if the user types "O'Malley" and you try to insert that into an SQL
database, you will lose big time because the single quote is magic
in SQL and the insert has to look like 'O''Malley'.
<p>
You should be using bind variables rather than
calling DoubleApos
@return string with single quotes converted to a pair of single quotes
} {
regsub -all ' "$string" '' result
return $result
}
# debugging kludges
ad_proc -public NsSettoTclString {set_id} {
returns a plain text version of the passed ns_set id
} {
set result ""
for {set i 0} {$i<[ns_set size $set_id]} {incr i} {
append result "[ns_set key $set_id $i] : [ns_set value $set_id $i]\n"
}
return $result
}
ad_proc -public get_referrer {-relative:boolean} {
@return referer from the request headers.
@param relative return the refer without protocol and host
} {
set url [ns_set get [ns_conn headers] Referer]
if {$relative_p} {
# In case the referrer URL has a protocol and host remove it
regexp {^[a-z]+://[^/]+(/.*)$} $url . url
}
return $url
}
##
# Database-related code
##
ad_proc -deprecated ad_dbclick_check_dml {
{-bind ""}
statement_name table_name id_column_name generated_id return_url insert_dml
} {
This proc is used for pages using double click protection. table_name
is table_name for which we are checking whether the double click
occurred. 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.
} {
if { [catch {
if { $bind ne "" } {
db_dml $statement_name $insert_dml -bind $bind
} else {
db_dml $statement_name $insert_dml
}
} errmsg] } {
# Oracle choked on the insert
# detect double click
if {
[db_0or1row double_click_check "
select 1 as one
from $table_name
where $id_column_name = :generated_id
" -bind [ad_tcl_vars_to_ns_set generated_id]]
} {
ad_returnredirect $return_url
return
}
ns_log Error "[info script] choked. Oracle returned error: $errmsg"
ad_return_error "Error in insert" "
We were unable to do your insert in the database.
Here is the error that was returned:
<p>
<blockquote>
<pre>
$errmsg
</pre>
</blockquote>
</p>"
return
}
ad_returnredirect $return_url
# should this be ad_script_abort? Should check how its being used.
return
}
ad_proc -public util_AnsiDatetoPrettyDate {
sql_date
} {
Converts 1998-09-05 to September 5, 1998
} {
set sql_date [string range $sql_date 0 9]
if { ![regexp {(.*)-(.*)-(.*)$} $sql_date match year month day] } {
return ""
} else {
set allthemonths {January February March April May June July August September October November December}
# we have to trim the leading zero because Tcl has such a
# brain damaged model of numbers and decided that "09-1"
# was "8.0"
set trimmed_month [string trimleft $month 0]
set pretty_month [lindex $allthemonths $trimmed_month-1]
set trimmed_day [string trimleft $day 0]
return "$pretty_month $trimmed_day, $year"
}
}
ad_proc -public remove_nulls_from_ns_set {
old_set_id
} {
Creates and returns a new ns_set without any null value fields
@return new ns_set
} {
set new_set_id [ns_set new "no_nulls$old_set_id"]
for {set i 0} {$i<[ns_set size $old_set_id]} {incr i} {
if { [ns_set value $old_set_id $i] ne "" } {
ns_set put $new_set_id [ns_set key $old_set_id $i] [ns_set value $old_set_id $i]
}
}
return $new_set_id
}
ad_proc -public merge_form_with_query {
{-bind {}}
form statement_name sql_qry
} {
Merges a form with a query string.
@param form the form to be stuffed.
@param statement_name An identifier for the sql_qry to be executed.
@param sql_qry The sql that must be executed.
@param bind A ns_set stuffed with bind variables for the sql_qry.
} {
set set_id [ns_set create]
ns_log debug "merge_form_with_query: statement_name = $statement_name"
ns_log debug "merge_form_with_query: sql_qry = $sql_qry"
ns_log debug "merge_form_with_query: set_id = $set_id"
db_0or1row $statement_name $sql_qry -bind $bind -column_set set_id
if { $set_id ne "" } {
for {set i 0} {$i<[ns_set size $set_id]} {incr i} {
set form [ns_formvalueput $form [ns_set key $set_id $i] [ns_set value $set_id $i]]
}
}
return $form
}
ad_proc -deprecated util_PrettyBoolean {t_or_f { default "default" } } {
} {
if { $t_or_f == "t" || $t_or_f eq "T" } {
return "Yes"
} elseif { $t_or_f == "f" || $t_or_f eq "F" } {
return "No"
} else {
# Note that we can't compare default to the empty string as in
# many cases, we are going want the default to be the empty
# string
if { $default eq "default" } {
return "Unknown (\"$t_or_f\")"
} else {
return $default
}
}
}
ad_proc util_PrettyTclBoolean {
zero_or_one
} {
Turns a 1 (or anything else that makes a Tcl IF happy) into Yes; anything else into No
} {
if {$zero_or_one} {
return "Yes"
} else {
return "No"
}
}
ad_proc -public randomInit {seed} {
seed the random number generator.
} {
nsv_set rand ia 9301
nsv_set rand ic 49297
nsv_set rand im 233280
nsv_set rand seed $seed
}
ad_proc -public random {} {
Return a pseudo-random number between 0 and 1.
} {
nsv_set rand seed [expr {([nsv_get rand seed] * [nsv_get rand ia] + [nsv_get rand ic]) % [nsv_get rand im]}]
return [expr {[nsv_get rand seed]/double([nsv_get rand im])}]
}
ad_proc -public randomRange {range} {
Returns a pseudo-random number between 0 and range.
@return integer
} {
incr range
return [expr {int([random] * $range) % $range}]
}
ad_proc -public db_html_select_options {
{ -bind "" }
{ -select_option "" }
stmt_name
sql
} {
Generate html option tags for an html selection widget. If select_option
is passed, this option will be marked as selected.
@author yon [yon@arsdigita.com]
} {
set select_options ""
if { $bind ne "" } {
set options [db_list $stmt_name $sql -bind $bind]
} else {
set options [db_list $stmt_name $sql]
}
foreach option $options {
if { $option eq $select_option } {
append select_options "<option selected=\"selected\">$option</option>\n"
} else {
append select_options "<option>$option</option>\n"
}
}
return $select_options
}
ad_proc -public db_html_select_value_options {
{ -bind "" }
{ -select_option "" }
{ -value_index 0 }
{ -option_index 1 }
stmt_name
sql
} {
Generate html option tags with values for an html selection widget. if
select_option is passed and there exists a value for it in the values
list, this option will be marked as selected. select_option can be passed
a list, in which case all options matching a value in the list will be
marked as selected.
@author yon [yon@arsdigita.com]
} {
set select_options ""
if { $bind ne "" } {
set options [db_list_of_lists $stmt_name $sql -bind $bind]
} else {
set options [uplevel [list db_list_of_lists $stmt_name $sql]]
}
foreach option $options {
if { [lindex $option $value_index] in $select_option } {
append select_options "<option value=\"[ns_quotehtml [lindex $option $value_index]]\" selected=\"selected\">[lindex $option $option_index]</option>\n"
} else {
append select_options "<option value=\"[ns_quotehtml [lindex $option $value_index]]\">[lindex $option $option_index]</option>\n"
}
}
return $select_options
}
#####
#
# Export Procs
#
#####
ad_proc -public export_vars {
-sign:boolean
-form:boolean
-url:boolean
-quotehtml:boolean
-entire_form:boolean
-no_empty:boolean
{-base}
-no_base_encode:boolean
{-anchor}
{-exclude {}}
{-override {}}
{vars {}}
} {
Exports variables either in URL or hidden form variable format. It should replace
<a
href="/api-doc/proc-view?proc=export_form_vars"><code>export_form_vars</code></a>,
<a
href="/api-doc/proc-view?proc=export_url_vars"><code>export_url_vars</code></a>
and all their friends.
<p>
Example usage: <code>[export_vars -form { foo bar baz }]</code>
<p>
This will export the three variables <code>foo</code>, <code>bar</code> and <code>baz</code> as
hidden HTML form fields. It does exactly the same as <code>[export_vars -form {foo bar baz}]</code>.
<p>
Example usage: <code>[export_vars -sign -override {{foo "new value"}} -exclude { bar } { foo bar baz }]</code>
<p>
This will export a variable named <code>foo</code> with the value "new value" and a variable named <code>baz</code>
with the value of <code>baz</code> in the caller's environment. Since we've specified that <code>bar</code> should be
excluded, <code>bar</code> won't get exported even though it's specified in the last argument. Additionally, even though
<code>foo</code> is specified also in the last argument, the value we use is the one given in the <code>override</code>
argument. Finally, both variables are signed, because we specified the <code>-sign</code> switch.
<p>
You can specify variables with <b>three different precedences</b>, namely
<b><code>override</code>, <code>exclude</code> or <code>vars</code></b>. If a variable is present in <code>override</code>,
that's what'll get exported, no matter what. If a variable is in <code>exclude</code> and not in <code>override</code>,
then it will <em>not</em> get output. However, if it is in <code>vars</code> and <em>not</em> in either of
<code>override</code> or <code>exclude</code>, then it'll get output. In other words, we check <code>override</code>,
<code>exclude</code> and <code>vars</code> in that order of precedence.
<p>
The two variable specs, <b><code>vars</code> and <code>override</code></b> both look the same: They take a list of
variable specs. Examples of variable specs are:
<ul>
<li>foo
<li>foo:multiple,sign
<li>{foo "the value"}
<li>{foo {[my_function arg]}}
<li>{foo:array,sign {[array get my_array]}}
</ul>
In general, there's one or two elements. If there are two, the second element is the value we should use. If one,
we pull the value from the variable of the same name in the caller's environment. Note that when you specify the
value directly here, we call <a href="http://dev.scriptics.com/man/tcl8.3/TclCmd/subst.htm"><code>subst</code></a>
on it, so backslashes, square brackets and variables will get substituted correctly. Therefore, make sure you use
curly braces to surround this instead of the <code>[list]</code> command; otherwise the contents will get substituted
twice, and you'll be in trouble.
<p>
Right after the name, you may specify a colon and some flags, separated by commas. Valid flags are:
<dl>
<dt><b>multiple</b></dt>
<dd>
Treat the value as a list and output each element separately.
</dd>
<dt><b>array</b></dt>
<dd>
The value is an array and should be exported in a way compliant with the <code>:array</code> flag of
<a href="/api-doc/proc-view?proc=ad_page_contract"><code>ad_page_contract</code></a>, which means
that each entry will get output as <code>name.key=value</code>.
<p>
If you don't specify a value directly, but want it pulled out of the Tcl environment, then you don't
need to specify <code>:array</code>. If you do, and the variable is in fact not an array, an error will
be thrown.
<p>
</dd>
<dt><b>sign</b></dt>
<dd>
Sign this variable. This goes hand-in-hand with the <code>:verify</code> flag of
<a href="/api-doc/proc-view?proc=ad_page_contract"><code>ad_page_contract</code></a> and
makes sure that the value isn't tampered with on the client side. The <code>-sign</code>
switch to <code>export_vars</code>, is a short-hand for specifying the <code>:sign</code> switch
on every variable.
<p>
For example, one can use now "user_id:sign(max_age=60)" in
export_vars to let the exported variable after 60 seconds.
</dd>
</dl>
The argument <b><code>exclude</code></b> simply takes a list of names of variables that you don't
want exported, even though they're specified in <code>vars</code>.
<p>
<b>Intended use:</b> A page may have a set of variables that it cares about. You can store this in
a variable once and pass that to <code>export_vars</code> like this:
<p><blockquote>
<code>set my_vars { user_id sort_by filter_by }<br>
... [export_vars $my_vars] ...</code>
</blockquote><p>
Then, say one of them contains a column to filter on. When you want to clear that column, you can say
<code>[export_vars -exclude { filter_by } $my_vars]</code>.
<p>
Similarly, if you want to change the sort order, you can say
<code>[export_vars -override { { sort_by $column } } $my_vars]</code>, and sorting will be done according to
the new value of <code>column</code>.
<p>
If the variable name contains a colon (:), that colon must be escaped with a backslash,
so for example "form:id" becomes "form\:id". Sorry.
@param sign Sign all variables.
@param url Export in URL format. This is the default.
@param form Export in form format. You can't specify both URL and form format.
@param quotehtml HTML quote the entire resulting string. This is an interim solution
while we're waiting for the templating system to do the quoting for us.
@param entire_form Export the entire form from the GET query string or the POST.
@option no_empty If specified, variables with an empty string value will be suppressed from being exported.
This avoids cluttering up the URLs with lots of unnecessary variables.
@option base The base URL to make a link to. This will be prepended to the query string
along with a question mark (?), if the query is non-empty. so the returned
string can be used directly in a link. This is only relevant to URL export.
@option no_base_encode Decides whether argument passed as <code>base</code> option will be
encoded by ad_urlencode_url proc
@author Lars Pind (lars@pinds.com)
@creation-date December 7, 2000
} {
if { $form_p && $url_p } {
return -code error "You must select either form format or url format, not both."
}
# default to URL format
if { !$form_p && !$url_p } {
set url_p 1
}
#
# TODO: At least the parsing of the options should be transformed
# to produce a single dict, containing the properties of all form
# vars (probably optionally) and specified arguments. The dict
# should be the straightforeward source for the genertion of the
# output set. One should be able to speed the code significantly
# up (at least for the standard cases).
#
# -Gustaf Neumann
#
# 'noprocessing_vars' is yet another container of variables,
# only this one doesn't have the values subst'ed
# and we don't try to find :multiple and :array flags in the namespec
set noprocessing_vars [list]
if { $entire_form_p } {
set the_form [ns_getform]
if { $the_form ne "" } {
for { set i 0 } { $i < [ns_set size $the_form] } { incr i } {
set varname [ns_set key $the_form $i]
set varvalue [ns_set value $the_form $i]
lappend noprocessing_vars [list $varname $varvalue]
}
}
}
#####
#
# Parse the arguments
#
#####
# 1. if they're in override, use those
# 2. if they're in vars, but not in exclude or override, use those
# There'll always be an entry here if the variable is to be exported
array set exp_precedence_type [list]
# This contains entries of the form exp_flag(name:flag) e.g., exp_flag(foo:multiple)
array set exp_flag [list]
# This contains the value if provided, otherwise we'll pull it out of the caller's environment
array set exp_value [list]
foreach precedence_type { override exclude vars noprocessing_vars } {
foreach var_spec [set $precedence_type] {
if { [llength $var_spec] > 2 } {
return -code error "A varspec must have either one or two elements."
}
if { $precedence_type ne "noprocessing_vars" } {
# Hide escaped colons for below split
regsub -all {\\:} $var_spec "!!cOlOn!!" var_spec
set name_spec [split [lindex $var_spec 0] ":"]
# Replace escaped colons with single colon
regsub -all {!!cOlOn!!} $name_spec ":" name_spec
set name [lindex $name_spec 0]
} else {
set name [lindex $var_spec 0]
# Nothing after the colon, since we don't interpret any colons
set name_spec [list $name {}]
}
# If we've already encountered this varname, ignore it
if { ![info exists exp_precedence_type($name)] } {
set exp_precedence_type($name) $precedence_type
if { $precedence_type ne "exclude" } {
foreach flag [split [lindex $name_spec 1] ","] {
set exp_flag($name:$flag) 0
if {[regexp {^(\w+)[\(](.+)[\)]$} $flag . flag value]} {
set exp_flag($name:$flag) $value
}
}
if { $sign_p } {
set exp_flag($name:sign) 0
}
if { [llength $var_spec] > 1 } {
if { $precedence_type ne "noprocessing_vars" } {
set value [uplevel subst \{[lindex $var_spec 1]\}]
} else {
set value [lindex $var_spec 1]
}
set exp_value($name) $value
# If the value is specified explicitly, we include it even if the value is empty
} else {
upvar 1 $name upvar_variable
if { [info exists upvar_variable] } {
if { [array exists upvar_variable] } {
if { $no_empty_p } {
# If the no_empty_p flag is set, remove empty string values first
set exp_value($name) [list]
foreach { key value } [array get upvar_variable] {
if { $value ne "" } {
lappend exp_value($name) $key $value
}
}
} else {
# If no_empty_p isn't set, just do an array get
set exp_value($name) [array get upvar_variable]
}
set exp_flag($name:array) 0
} else {
if { [info exists exp_flag($name:array)] } {
return -code error "Variable \"$name\" is not an array"
}
if { !$no_empty_p } {
set exp_value($name) $upvar_variable
} else {
# no_empty_p flag set, remove empty strings
if { [info exists exp_flag($name:multiple)] } {
# This is a list, remove empty entries
set exp_value($name) [list]
foreach elm $upvar_variable {
if { $elm ne "" } {
lappend exp_value($name) $elm
}
}
} else {
# Simple value, this is easy
if { $upvar_variable ne "" } {
set exp_value($name) $upvar_variable
}
}
}
}
}
}
}
}
}
}
#####
#
# Put the variables into the export_set
#
#####
# We use an ns_set, because there may be more than one entry with the same name
set export_set [ns_set create]
foreach name [array names exp_precedence_type] {
if { $exp_precedence_type($name) ne "exclude" } {
if { [info exists exp_value($name)] } {
if { [info exists exp_flag($name:array)] } {
if { [info exists exp_flag($name:multiple)] } {
foreach { key value } $exp_value($name) {
foreach item $value {
ns_set put $export_set "${name}.${key}" $item
}
}
} else {
foreach { key value } $exp_value($name) {
ns_set put $export_set "${name}.${key}" $value
}
}
if { [info exists exp_flag($name:sign)] } {
# DRB: array get does not define the order in which elements are returned,
# meaning that arrays constructed in different ways can have different
# signatures unless we sort the returned list. I ran into this the
# very first time I tried to sign an array passed to a page that used
# ad_page_contract to verify the veracity of the parameter.
ns_set put $export_set "$name:sig" \
[export_vars_sign -params $exp_flag($name:sign) [lsort $exp_value($name)]]
}
} else {
if { [info exists exp_flag($name:multiple)] } {
foreach item $exp_value($name) {
ns_set put $export_set $name $item
}
} else {
ns_set put $export_set $name "$exp_value($name)"
}
if { [info exists exp_flag($name:sign)] } {
ns_set put $export_set "$name:sig" \
[export_vars_sign -params $exp_flag($name:sign) $exp_value($name)]
}
}
}
}
}
#####
#
# Translate it into the appropriate format
#
#####
set export_size [ns_set size $export_set]
set export_string {}
if { $url_p } {
set export_list [list]
for { set i 0 } { $i < $export_size } { incr i } {
lappend export_list [ad_urlencode_query [ns_set key $export_set $i]]=[ad_urlencode_query [ns_set value $export_set $i]]
}
set export_string [join $export_list "&"]
} else {
for { set i 0 } { $i < $export_size } { incr i } {
append export_string [subst {<div><input type="hidden"
name="[ns_quotehtml [ns_set key $export_set $i]]"
value="[ns_quotehtml [ns_set value $export_set $i]]"></div>
}]
}
}
if { $quotehtml_p } {
set export_string [ns_quotehtml $export_string]
}
# Prepend with the base URL
if { [info exists base] && $base ne "" } {
if { [string first ? $base] > -1 } {
# The base already has query vars; assume that the
# path up to this point is already correctly encoded.
set export_string $base[expr {$export_string ne "" ? "&$export_string" : ""}]
} else {
# The base has no query vars: encode url part if not
# explicitly said otherwise. Include also as exception
# trivial case of the base being the dummy url '#'.
if {!$no_base_encode_p && $base ne "#"} {
set base [ad_urlencode_url $base]
}
set export_string $base[expr {$export_string ne "" ? "?$export_string" : ""}]
}
}
# Append anchor
if { [info exists anchor] && $anchor ne "" } {
append export_string "\#$anchor"
}
return $export_string
}
ad_proc -private export_vars_sign {
{-params ""}
value
} {
Call ad_sign parameterized via max_age and secret specified in urlencoding
} {
set max_age ""
set secret [ns_config "ns/server/[ns_info server]/acs" parametersecret ""]
foreach def [split $params &] {
lassign [split $def =] key val
switch $key {
max_age -
secret {set $key [ad_urldecode_query $val]}
}
}
return [ad_sign -max_age $max_age -secret $secret $value]
}
ad_proc -deprecated ad_export_vars {
-form:boolean
{-exclude {}}
{-override {}}
{include {}}
} {
<b><em>Note</em></b> This proc is deprecated in favor of
<a href="/api-doc/proc-view?proc=export_vars"><code>export_vars</code></a>. They're very similar, but
<code>export_vars</code> have a number of advantages:
<ul>
<li>It can sign variables (the the <code>:sign</code> flag)
<li>It can export variables as a :multiple.
<li>It can export arrays with on-the-fly values (not pulled from the environment)
</ul>
It doesn't have the <code>foo(bar)</code> syntax to pull a single value from an array, however, but
you can do the same by saying <code>export_vars {{foo.bar $foo(bar)}}</code>.
<p>