summaryrefslogtreecommitdiff
path: root/web/config/alpine.tcl
blob: 8199c00239bbc075006a5ce8f7dfb33ab52acf61 (plain)
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
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
# Web Alpine Config options
# $Id: alpine.tcl 1266 2009-07-14 18:39:12Z hubert@u.washington.edu $
# ========================================================================
# Copyright 2006-2008 University of Washington
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# ========================================================================

encoding system "utf-8"

set _wp(appname)	Alpine
set _wp(admin)		admin@sample-domain.edu
set _wp(helpdesk)	admin@sample-domain.edu
set _wp(comments)	help@sample-domain.edu

# List of userid's allowed to request the monitor script output
set _wp(monitors)	{}

# directory prefix web server uses for web alpine page requests
# Note: set to {} if DocumentRoot set to the root of web alpine cgi scripts
set _wp(urlprefix)	webmail

# file system path to CGI application files
# directory containing web alpine application scripts and supporting tools
# The htdocs/ directory is located at /srv/www/htdocs. Here we copy the
# web directory to /srv/www/Webalpine/web using "tar cf" followed by
# "tar xf" which preserves symbolic links
# Original configuration:
#set _wp(fileroot)	/usr/local/libexec/alpine
set _wp(fileroot)	/srv/www/Webalpine/web


set _wp(tmpdir)		/tmp

# NOTE: Make SURE tclsh and alpine.tcl symlinks in this directory
set _wp(cgipath)	[file join $_wp(fileroot) cgi]

# CGI scripts implementing U/I, session cookie scope
set _wp(appdir)		alpine

# UI versions
set _wp(ui1dir)		1.0
set _wp(ui2dir)		2.0

# place for CGI scripts not requiring session-key
set _wp(pubdir)		pub

# place for binaries referenced by the CGI scripts
set _wp(bin)		[file join $_wp(fileroot) bin]
set _wp(servlet)	alpined
set _wp(pc_servlet)	pc_alpined
set _wp(pldap)          alpineldap

# place for config files referenced by the CGI scripts
set _wp(confdir)	[file join $_wp(fileroot) config]
set _wp(conffile)	pine.conf
set _wp(defconf)	$_wp(conffile)

# place for library files used by CGI scripts
set _wp(lib)		[file join $_wp(fileroot) lib]

# directory used temporarily to stage attached and detached files
# this directory is owned by wwwrun:www
set _wp(detachpath)	[file join $_wp(fileroot) detach]

set _wp(imagepath)	[file join / $_wp(urlprefix) images]

set _wp(buttonpath)	[file join $_wp(imagepath) buttons silver]

set _wp(staticondir)	env

set _wp(servername)	[info hostname]

# MUST specify SSL/TLS connection
set _wp(serverport)	{}
set _wp(serverpath)	https://[file join [join [eval list $_wp(servername) $_wp(serverport)] :] $_wp(urlprefix)]

# MAY specify a plaintext connection (comment out if plain support undesired)
set _wp(plainport)	{}
set _wp(plainservpath)	http://[file join [join [eval list $_wp(servername) $_wp(plainport)] :] $_wp(urlprefix)]

# url of faq page(s) available from initial greeting page
#set _wp(faq)		"http://www.yourserver/faqs/alpine.html"

# url of informational page accessible from initial greeting page
set _wp(releaseblurb)	"$_wp(plainservpath)/alpine/help/release.html"

# url of previous version server to be accessible from initial greeting page
#set _wp(oldserverpath)	"https://previous.version.server.edu:444/"

# session id length: make sure the integer count below matches what's built
# into the pubcookie: "src/pubcookie/wp_uidmapper_lib.h:#define WP_KEY_LEN 6"
set _wp(sessidlen)	6

# Where and what format the alpined comm socket should take
set _wp(sockdir)	$_wp(tmpdir)
set _wp(sockpat)	wp%s

# skin settings
set _wp(bordercolor)	#FEFAC9
set _wp(menucolor)	#3E2E6D
set _wp(dialogcolor)	#FEFAC9
set _wp(titlecolor)	#000000
set _wp(logodir)	alpine

# various timerouts, dimensions and feature settings
set _wp(refresh)	600
set _wp(timeout)	900
set _wp(autodraft)	300
set _wp(logoutpause)	60
set _wp(indexlines)	20
set _wp(indexlinesmax)	50
set _wp(indexheight)	24
set _wp(navheight)	28
set _wp(width)		80
set _wp(titleheight)	34
set _wp(titlesep)	4
set _wp(config)		remote_pinerc
set _wp(motd)		motd
set _wp(save_cache_max)	6
set _wp(fldr_cache_max)	20
set _wp(fldr_cache_def)	3
set _wp(statushelp)	0
set _wp(imgbuttons)	0
set _wp(keybindings)	1
set _wp(dictionary)	0
set _wp(debug)		0
set _wp(cmdtime)	0
set _wp(evaltime)	0
set _wp(menuargs)	{width="112" nowrap valign=top}
set _wp(ispell)		/usr/local/bin/ispell

# Yahoo! User Interface Library location
set _wp(yui)		$_wp(serverpath)/$_wp(appdir)/$_wp(ui2dir)/lib/yui
#set _wp(yui)		"http://yui.yahooapis.com/2.7.0"

# usage reporter - input: username as first command line argument
#                  output: space separated integers usage and total
#set _wp(usage)		$_wp(bin)/usage.tcl
#set _wp(usage_link)	"https://uwnetid.washington.edu/disk/"

# limit uploads to 1 file at a time, maximum 20MB.
set _wp(uplim_files)	1
set _wp(uplim_bytes)	20000000

# verify sessid from consistent REMOTE_ADDR (set to 0 for proxying clusters)
set _wp(hostcheck)	0

# set to list of domains for which ssl is NOT required
#set _wp(ssl_safe_domains)	{}

# set to list of address blocks or ranges for which ssl is NOT required
#set _wp(ssl_safe_addrs)		{}

# set this value to zero to turn OFF ssl by default
set _wp(ssl_default)	1

# allow connecting user to specify imap server on greeting page
set	_wp(flexserver)	1

# make sure tmp files and such are ours alone to read/write
catch {exec umask 044}

#fix up indexheight so it isn't too high or too low
set _wp(indexheight) [expr {$_wp(indexheight) <= 20 ? 20 : $_wp(indexheight) >= 30 ? 30 : $_wp(indexheight)}]

# SPAM reporting facility, if set "Report Spam" button appears at top of View Page
#set _wp(spamaddr)	spamaddr@sample-domain.edu
#set _wp(spamfolder)	junk-mail
#set _wp(spamsubj)	"ATTACHED SPAM"

# external mail filter config link
#set _wp(filter_link)	http://delivery-filter.sample-domain.edu/filter/config

# external vacation config link
#set _wp(vacation_link)	http://vacation.sample-domain.edu/vacation/config

#
# Nickname server bindings.  If not present, prompt for the
# destination of the default pinerc location.
#
set _wp(hosts) {
    {
      Gmail
      imap.gmail.com/ssl
      $_wp(confdir)/gmail.conf
    }
    {
      GMX
      imap.gmx.com/ssl
      $_wp(confdir)/gmx.conf
    }
    {
      Deskmail
      $User.deskmail.washington.edu/ssl
      $_wp(confdir)/conf.deskmail
    }
}

# Everybody inherits the cgi, comm packages
lappend auto_path $_wp(lib)

package require cgi
package require WPComm

# Recipient of bad news bubbling up from cgi.tcl...
cgi_admin_mail_addr $_wp(admin)

cgi_sendmail {}

#cgi_mail_relay localhost
cgi_mail_relay smtpserver.sample-domain.edu

# set permissions for owner-only handling
cgi_tmpfile_permissions 0640

#set upload limits
cgi_file_limit $_wp(uplim_files) $_wp(uplim_bytes)

# universal body tag parameters
cgi_body_args link=#0000FF vlink=#000080 alink=#FF0000 marginwidth=0 marginheight=0 topmargin=0 leftmargin=0

# Common Images Image definitions
cgi_imglink logo		[file join $_wp(imagepath) logo $_wp(logodir) big.gif]	border=0	"alt=Web Alpine"
cgi_imglink smalllogo		[file join $_wp(imagepath) logo $_wp(logodir) small.gif]	border=0	"alt=About Web Alpine"
cgi_imglink background		[file join $_wp(imagepath) logo $_wp(logodir) back.gif]		border=0	align=top
cgi_imglink dot			[file join $_wp(imagepath) dot2.gif]		border=0	align=top
cgi_imglink increas		[file join $_wp(imagepath) increas4.gif]	border=0	align=absmiddle
cgi_imglink decreas		[file join $_wp(imagepath) decreas4.gif]	border=0	align=absmiddle
cgi_imglink expand		[file join $_wp(imagepath) b_plus.gif]	border=0	"alt=Expand"	height=9 width=9
cgi_imglink contract		[file join $_wp(imagepath) b_minus.gif]	border=0	"alt=Collapse"	height=9 width=9
cgi_imglink fullhdr		[file join $_wp(imagepath) hdr.gif]		border=0	"alt=Full Header"
cgi_imglink nofullhdr		[file join $_wp(imagepath) hdrnon.gif]	border=0	"alt=Digested Header"
cgi_imglink bang		[file join $_wp(imagepath) caution.gif]	border=0	"alt=!"
cgi_imglink postmark		[file join $_wp(imagepath) postmark.gif]	border=0	"alt=New Mail"
cgi_imglink gtab		[file join $_wp(imagepath) tabs gtab.gif]	border=0	align=top
cgi_imglink gdtab		[file join $_wp(imagepath) tabs gdtab.gif]	border=0	align=top
cgi_imglink abtab		[file join $_wp(imagepath) tabs abtab.gif]	border=0	align=top
cgi_imglink abdtab		[file join $_wp(imagepath) tabs abdtab.gif]	border=0	align=top
cgi_imglink ctab		[file join $_wp(imagepath) tabs ctab.gif]	border=0	align=top
cgi_imglink cdtab		[file join $_wp(imagepath) tabs cdtab.gif]	border=0	align=top
cgi_imglink ftab		[file join $_wp(imagepath) tabs ftab.gif]	border=0	align=top
cgi_imglink fdtab		[file join $_wp(imagepath) tabs fdtab.gif]	border=0	align=top
cgi_imglink mltab		[file join $_wp(imagepath) tabs mltab.gif]	border=0	align=top
cgi_imglink mldtab		[file join $_wp(imagepath) tabs mldtab.gif]	border=0	align=top
cgi_imglink mvtab		[file join $_wp(imagepath) tabs mvtab.gif]	border=0	align=top
cgi_imglink mvdtab		[file join $_wp(imagepath) tabs mvdtab.gif]	border=0	align=top
cgi_imglink rtab		[file join $_wp(imagepath) tabs rtab.gif]	border=0	align=top
cgi_imglink rdtab		[file join $_wp(imagepath) tabs rdtab.gif]	border=0	align=top


# Link definitions
cgi_link Admin "Web Alpine Administrator" "mailto:$_wp(admin)"
cgi_link Start "Web Alpine Home Page" "$_wp(serverpath)/session/greeting.tcl" target=_top

# Internally referenced CGI directory root
cgi_root $_wp(serverpath)
cgi_suffix .tcl

# have cgi.tcl convert eols in muiltipart/form-data
set _cgi(no_binary_upload) 1

proc WPSocketName {sessid} {
  global _wp

  return [file join $_wp(sockdir) [format $_wp(sockpat) $sessid]]
}

proc WPValidId {{sessid {}}} {
    global _wp env

    if {[string length $sessid] == 0} {
      set created 1

      # Session Handle: a bit reasonably random number.  the format
      # is convenient for pubcookie auth'd support
      set rnum {}
      set rsrc /dev/urandom
      set idbytelength [expr {$_wp(sessidlen) * 4}]
      if {[file readable $rsrc] && [catch {open $rsrc r} fp] == 0} {
	while {1} {
	  for {set i 0} {$i < $idbytelength} {incr i} {
	    if {$i && ($i % 4) == 0} {
	      append rnum "."
	    }

	    if {[catch {read $fp 1} n] == 0} {
	      binary scan $n c x
	      set x [expr ($x & 0xff)]
	      append rnum [format {%02x} $x]
	    } else {
	      set rnum {}
	      break
	    }
	  }

	  if {[file exists [WPSocketName $rnum]]} {
	    set rnum {}
	  } else {
	    break
	  }
	}

	close $fp
      }

      # second choice for random numbers
      if {[string length $rnum] == 0} {
	expr srand([clock seconds])
	for {set i 0} {$i < $idbytelength} {incr i 4} {
	  if {$i && ($i % 4) == 0} {
	    append rnum "."
	  }

	  append rnum [format {%08x} [expr int((100000000 * rand()))]]
	}
      }

      # generate a session ID
      set _wp(sessid) $rnum
    } else {
      set sessidparts [split $sessid {@}]
      switch [llength $sessidparts] {
	1 {
	  set _wp(sessid) $sessid
	}
	2 {
	  if {[string compare [string tolower [lindex $sessidparts 1]] [string tolower [info hostname]]]} {
	    regexp {^([a-zA-Z]*://).*} [cgi_root] match proto
	    error [list redirect "${proto}[lindex $sessidparts 1]:$env(SERVER_PORT)?$env(QUERY_STRING)"]
	  } else {
	    set _wp(sessid) [lindex $sessidparts 0]
	  }
	}
	default {
	  error "Malformed Session ID: $sessid"
	}
      }
    }

    set _wp(sockname) [WPSocketName $_wp(sessid)]

    if {[info exists _wp(cumulative)]} {
      rename WPCmd WPCmd.orig
      rename WPCmdTimed WPCmd
    }

    if {[info exists _wp(hostcheck)] && $_wp(hostcheck) == 1 && ![info exists created]
	&& [catch {WPCmd set wp_client} client] == 0
	&& (([info exists env(REMOTE_ADDR)] && [string length $env(REMOTE_ADDR)] && [string compare $client $env(REMOTE_ADDR)])
	    || ([info exists env(REMOTE_HOST)] && [string length $env(REMOTE_HOST)] && [string compare $client $env(REMOTE_HOST)]))} {
      error "Request from unrecognized client"
    }
}

proc WPAbort {} {
    WPCleanup
    cgi_exit
}

proc WPCleanup {} {
    global _wp

    if {[info exists _wp(cleanup)]} {
	foreach item $_wp(cleanup) {
	    catch {eval $item}
	}
    }
}

proc WPEval {vars cmd} {
    global _wp

    if {$_wp(cmdtime) || $_wp(evaltime)} {
	set _wp(cumulative) 0
    }

    set _wp(cmd) $cmd
    set _wp(vars) [linsert $vars 0 [list sessid "Missing Session ID"]]

    uplevel 1 {
      cgi_eval {
	if {$_wp(debug) > 1} {
	    cgi_debug -on
	}

	# Session id?
	if {[catch {WPGetInputAndID sessid}]} {
	  return
	}

	foreach item $_wp(vars) {
	  if {[catch {eval WPImport $item} errstr]} {
	    WPInfoPage "Web Alpine Error" [font size=+2 $errstr] "Please close this window."
	    return
	  }
	}

	# evaluate the given script
	if {[catch {cgi_buffer $_wp(cmd)} result]} {

	    reset_cgi_state

	    if {[string index $result 0] == "_"} {
	      switch -- [lindex $result 0] {
		_info {
		  WPInfoPage [lindex $result 1] [font size=+2 [lindex $result 2]] [lindex $result 3]
		}
		_action {
		  switch -regexp -- [lindex $result 2] {
		    "[Ii]nactive [Ss]ession" {
		      WPInactivePage
		    }
		    default {
		      if {[string length [lindex $result 3]]} {
			set remedy [lindex $result 3]
		      } else {
			set remedy "   Click your browser's Back button to return to previous page."
		      }
		      WPInfoPage "[lindex $result 1] Error" [font size=+2 [lindex $result 2]] \
			  "Please report this to the [cgi_link Admin].$remedy"
		    }
		  }
		}
		_redirect {
		  cgi_http_head {
		    cgi_redirect [lindex $result 1]
		  }

		  cgi_html { cgi_body {} }
		}
		_close {
		  if {[string length [lindex $result 1]] == 0} {
		    set result "Indeterminate error"
		  }

		  WPInfoPage "Web Alpine Error" [font size=+2 [lindex $result 1]] "Please close this window."
		}
		default {
		  if {[string length $result]} {
		    WPInfoPage "Web Alpine Error" [font size=+2 "Eval Error: $result"] \
			"Please complain to the [cgi_link Admin].   Click Back button to return to previous page."
		  } else {
		    WPInfoPage "Web Alpine Error" [font size=+2 "Indeterminate error response"] \
			"Please complain to the [cgi_link Admin] and click Back button to return to previous page."
		  }
		}
	      }
	    } else {
	      if {[regexp {[Ii]nactive [Ss]ession} $result]} {
		WPInactivePage
	      } else {
		WPInfoPage "Web Alpine Error" [font size=+2 "Error: $result"] \
		    "Please report this to the [cgi_link Admin]. Try clicking your browser's Back button to return to a working page."
	      }
	    }
	} else {
	    catch {cgi_puts $result}
	}
    }
  }

    # cleanup here
    WPCleanup

    if {[info exists _wp(cumulative)]} {
      WPdebug "Cumulative Eval: $_wp(cumulative)"
      unset _wp(cumulative)
    }
}

proc WPGetInputAndID {_sessid} {
  global _wp
  upvar $_sessid sessid

  # Import data and validate it
  if {[catch {cgi_input "sessid=8543949466398&"} result]} {
    WPInfoPage "Web Alpine Error" [font size=+2 $result] "Please close this window."
    error "Cannot get CGI Input"
  }

  if {[catch {WPImport sessid "Missing Session ID"} errstr]} {
    if {[regexp {.*sessid.*no such.*} $errstr]} {
      WPInactivePage [list "Your browser may have failed to send the necessary <i>cookie</i> information.  Please verify your browser configuration has cookies enabled."]
    } else {
      WPInfoPage "Web Alpine Error" [font size=+2 $errstr] "Please close this window."
    }

    error "Session ID Failure"
  } else {
    # initialization here
    if {[catch {WPValidId $sessid} result]} {
      if {[string compare [lindex $result 0] redirect]} {
	WPInfoPage "Web Alpine Error" [font size=+2 "$result"] \
	    "Please complain to the [cgi_link Admin] and visit the [cgi_link Start] later."
      } else {
	cgi_http_head {
	  cgi_redirect [lindex $result 1]
	}
      }

      error "Unrecoverable Error"
    } elseif {$_wp(sessid) == 0} {
      WPInactivePage
      error "Inactive Session"
    }

    if {[catch {WPCmd set serverroot} serverroot] == 0} {
      cgi_root $serverroot
    }
  }
}

proc WPCmdEval {args} {
  return [eval $args]
}

proc WPCmd {args} {
  global _wp

  return [WPSend $_wp(sockname) $args]
}

proc WPCmdTimed {args} {
  global _wp

  set t [lindex [time {set r [WPSend $_wp(sockname) $args]}] 0]
  incr _wp(cumulative) $t

  if {$_wp(cmdtime)} {
    WPdebug "time $t : $args"
  }

  return $r
}

proc WPLoadCGIVar {_var} {
  upvar $_var var

  if {[catch {cgi_import_as $_var var} result]
      && [catch {WPCmd set $_var} var]
      && [catch {cgi_import_cookie_as $_var var} result]} {
    error [list _action "Import Cookie $_var" $result]
  }
}

proc WPLoadCGIVarAs {_var _varas} {
    upvar $_varas varas

  if {[catch {cgi_import_as $_var varas} result]
      && [catch {WPCmd set $_var} varas]
      && [catch {cgi_import_cookie_as $_var varas} result]} {
    set varas ""
  }
}

proc WPImport {valname {errstring ""} {default 0}} {
    upvar $valname val

    if {[catch {cgi_import_as $valname val} result]} {
      if {[catch {WPCmd set $valname} val]} {
	if {[catch {cgi_import_cookie_as $valname val} result]} {
	  if {[string length $errstring] > 0} {
	    error "$errstring: $result"
	  } else {
	    set val $default
	  }
	}
      }
    }
}


proc WPExportCookie {name value {scope ""}} {
    global _wp

    cgi_cookie_set $name=$value "path=[file join / $_wp(urlprefix) $scope]"
}


# handle dynamic sizing of images showing thread relationships 
proc WPThreadImageLink {t h} {
    global _wp

    return "<img src=\"[file join $_wp(imagepath) ${t}.gif]\" border=0 align=top height=${h} width=14>"
}


proc WPInactivePage {{reasons ""}} {
  set l {}
  foreach r $reasons {
    append l "<li>$r"
  }

  WPInfoPage "Inactive Session" \
	"[font size=+2 "Web Alpine Session No Longer Active"]" \
      "There are several reasons why a session might become inactive.<ul><li>A bookmarked reference to a Web Alpine page.<li>Failed periodic page reload due to browser/system suspension associated with power saving mode, etc.${l}</ul><p>Please visit the [cgi_link Start] to start a new session."
}

proc WPInfoPage {title exp1 {exp2 ""} {imgurl {}} {exp3 ""}} {
  global _wp

  catch {

    cgi_html {
      cgi_head {
	cgi_title $title
	cgi_stylesheet [file join / $_wp(urlprefix) $_wp(pubdir) standard.css]
      }

      cgi_body {
	cgi_table height="20%" {
	  cgi_table_row {
	    cgi_table_data {
	      cgi_puts [cgi_nbspace]
	    }
	  }
	}

	cgi_center {
	  cgi_table border=0 width=500 cellpadding=3 {
	    cgi_table_row {
	      cgi_table_data align=center rowspan=3 {
		if {[string length $imgurl]} {
		  cgi_put [cgi_url [cgi_imglink logo] $imgurl]
		} else {
		  cgi_put [cgi_imglink logo]
		}
	      }

	      cgi_table_data rowspan=3 {
		cgi_put [nbspace]
		cgi_put [nbspace]
	      }

	      cgi_table_data {
		cgi_puts $exp1
	      }

	    }

	    if {[string length $exp3]} {
	      cgi_table_row {
		cgi_table_data "style=\"border: 1px solid red; background-color: pink\"" {
		  cgi_puts $exp3
		}
	      }
	    }

	    if {[string length $exp2]} {
	      cgi_table_row {
		cgi_table_data {
		  cgi_puts $exp2
		}
	      }
	    }
	  }
	}
      }
    }
  }
}

proc WPimg {image {extension gif}} {
    global _wp

    return [file join $_wp(imagepath) ${image}.${extension}]
}

proc WPCharValue {c} {
  scan "$c" %c n
  return $n
}

proc WPPercentQuote {arg {exclude {}}} {
  set t "\[^0-9a-zA-Z_${exclude}\]"
  if {[regsub -all $t $arg {[format "%%%.2X" [WPCharValue "\\&"]]} subarg]} {
    set x [subst $subarg]
    return $x
  } else {
    return $arg
  }
}

proc WPJSQuote {l} {
  regsub -all {([\\'])} $l {\\\1} l
  return $l
}

proc WPurl {cmd cmdargs text explanation args} {
    global _wp

    lappend urlargs $text
    lappend urlargs $cmd
    if {[regexp "^java*" $cmd] == 0 && [string first . $cmd] < 0} {
	append urlargs ".tcl"
    }

    if {[string length $cmdargs]} {
	if {[set i [string first "?" $cmdargs]] >= 0} {
	    append urlargs "[cgi_quote_url [string range $cmdargs 0 [expr {$i - 1}]]]?[cgi_quote_url [string range $cmdargs [incr i] end]]"
	} else {
	    append urlargs "?[cgi_quote_url $cmdargs]"
	}
    }

    if {$_wp(statushelp)} {
	lappend urlargs [WPmouseover $explanation]
	lappend urlargs "onMouseOut=window.status=''"
    }

    return [eval "cgi_url $urlargs $args"]
}

proc WPMenuURL {cmd cmdargs text explanation args} {
    return [WPurl $cmd $cmdargs $text $explanation class=menubar [join $args]]
}

proc WPGetTDFontSize {{ih 24}} {
    if {$ih <= 20 } {return 12}
    if {$ih >= 30 } {return 24}
    return [expr {$ih - 8}]
}
  
proc WPGetviewFontSize {{ih 24}} {
    if {$ih <= 20 } {return 8}
    if {$ih >= 30 } {return 13}
    return [expr {($ih / 2) - 2}]
}

proc WPIndexLineHeight {{ih 0}} {
  global _wp

  set ih [WPCmd PEInfo indexheight]
  if {[string length $ih] == 0 ||  $ih <= 0} {
    set ih $_wp(indexheight)
  }

  return [expr {($ih < 20) ? 20 : $ih}]
}

proc WPStyleSheets {{ih 0}} {
  global _wp

  cgi_stylesheet [file join / $_wp(urlprefix) $_wp(pubdir) standard.css]

  if {$ih <= 0} {
    set ih [WPIndexLineHeight]
  }

  cgi_puts "<style type='text/css'>\nTD { font-size: [WPGetTDFontSize $ih]px }\n.view {font-size: [WPGetviewFontSize $ih]pt }\n</style>"
  return $ih
}

proc WPStdScripts {{ih 0}} {
    global _wp

    set ih [WPStyleSheets $ih]

    cgi_script language="JavaScript" src="[file join / $_wp(urlprefix) $_wp(pubdir) standard.js]" {}
    cgi_script language="JavaScript1.3" {cgi_put "js_version = '1.3';"}
    cgi_javascript {
	cgi_puts "function getIndexHeight(){return $ih}"
    }
}

proc WPStdHttpHdrs {{ctype {}} {expires 0}} {
    global _wp

    # set date and expires headers the same to prevent caching
    # Date: Tue, 15 Nov 1994 08:12:31 GMT
    set doctime [clock seconds]

    if {[string length $ctype]} {
      cgi_content_type $ctype
    } else {
      cgi_content_type
    }

    cgi_puts "Date: [clock format $doctime -gmt true -format "%a, %d %b %Y %H:%M:%S GMT"]"
    if {$expires == 0} {
      set _wp(nocache) 1
      cgi_puts "Cache-Control: no-cache"
      cgi_puts "Expires: [clock format [expr {$doctime - 31536000}] -gmt true -format "%a, %d %b %Y %H:%M:%S GMT"]"
    } elseif {$expires > 0} {
      cgi_puts "Expires: [clock format [expr {$doctime + ($expires * 60)}] -gmt true -format "%a, %d %b %Y %H:%M:%S GMT"]"
    }
}

proc WPStdHtmlHdr {pagetitle {pagescript ""} {newmail 0}} {
    global _wp

    if {0 && $newmail} {
      set nm "* "
    } else {
      set nm ""
    }

    cgi_title "${nm}Web Alpine - $pagetitle"
    # cgi_base "href=$_wp(serverpath)/"
    if {[info exists _wp(nocache)]} {
      cgi_http_equiv Pragma no-cache
    }

    # cgi_http_equiv Expires $_wp(docdate)
    cgi_meta "name=Web Alpine" content=[clock format [file mtime [info script]] -format "%y%m%d/%H%M"]
    if {[catch {WPCmd set nojs} nojs] || $nojs != 1} {
      cgi_script  type="text/javascript" language="JavaScript" {
	cgi_puts "if(self != top) top.location.href = location.href;"
	cgi_puts "js_version = '1.0';"
      }
    }

    cgi_put  "<link rel=\"icon\" href=\"[cgi_root]/favicon.ico\" type=\"image/x-icon\">"
    cgi_put  "<link rel=\"shortcut icon\" href=\"[cgi_root]/favicon.ico\" type=\"image/x-icon\"> "
}

proc WPHtmlHdrReload {pagescript} {
  global _wp

  if {[regexp {\?} $pagescript]} {
    set c "&"
  } else {
    set c "?"
  }

  cgi_http_equiv Refresh "$_wp(refresh); url=[cgi_root]/${pagescript}${c}reload=1"
}

proc WPNewMail {reload {viewpage msgview.tcl}} {

    if {[catch {WPCmd PEMailbox newmail $reload} newmail]} {
	return -code error $newmail
    }

    set newref ""

    if {[set msgsnew [lindex $newmail 0]] > 0} {
      if {[string length $viewpage]} {
	if {[string first {?} $viewpage] < 0} {
	  set delim ?
	} else {
	  set delim &
	}

	set newurl "${viewpage}${delim}uid=[lindex $newmail 1]"
      } else {
	set newurl [lindex $newmail 1]
      }

      set newicon "postmark"
      set newtext [cgi_quote_html [WPCmd PEMailbox newmailstatmsg]]

      if {[WPCmd PEInfo feature enable-newmail-sound]} {
        #set audio sounds/mail_msg.wav
	set audio /sounds/ding.wav
	if {[isIE]} {
	  set newsound "<bgsound src=\"$audio\" loop=\"1\" volume=\"100\">"
	} else {
	  set newsound "<embed src=\"$audio\" autostart=\"true\" hidden width=0 height=0 loop=\"false\"><noembed><bgsound src=\"$audio\" loop=\"1\"></noembed>"
	}
      } else {
	set newsound {}
      }

      if {0 == [string length $newtext]} {
	set newtext "You have $msgsnew new message[WPplural $msgsnew]"
      }

      lappend newref [list $newtext $newicon $newurl $newsound]
    }

    if {[set deleted [lindex $newmail 2]] > 0} {
	set newtext "$deleted Message[WPplural $deleted] removed from folder"
	lappend newref [list $newtext "" ""]
    }

    foreach statmsg [WPStatusMsgs] {
      lappend newref [list $statmsg "" ""]
      WPCmd PEInfo statmsg ""
    }

    if {!$reload} {
	WPCmd PEMailbox newmailreset
    }

    return $newref
}

proc WPStatusMsgs {} {
  set retmsgs ""
  set lastmsg ""
  if {[catch {WPCmd PEInfo statmsgs} statmsgs] == 0} {
    foreach statmsg $statmsgs {
      if {[string length $statmsg] > 0 && [string compare $statmsg $lastmsg]} {
	if {[regexp "^Pinerc \(.+\) NOT saved$" $statmsg]} {
	  lappend retmsgs "Another Pine/WebPine session may be running.  Settings cannot be saved."
	} else {
	  lappend retmsgs $statmsg
	}

	set lastmsg $statmsg
      }
    }
  }

  return $retmsgs
}

proc WPStatusIcon {uid {extension gif} {statbits ""}} {
  global _wp

  if {[string length $statbits] == 0} {
    set statbits [WPCmd PEMessage $uid statusbits]
  }

  if {[string index $statbits 0]} {
    append sicon "new"
    set alt " N"
    set fullalt "New "
  } else {
    append sicon "read"
    set alt "  "
    set fullalt "Viewed "
  }

  if {[string index $statbits 3]} {
    append sicon "imp"
    set alt "*[string range $alt 1 end]"
    set fullaltend ", important message"
  } elseif {([string index $statbits 4] || [string index $statbits 5])} {
    append sicon "you"
    set alt "+[string range $alt 1 end]"
    set fullaltend " message to you"
  }

  if {[string index $statbits 2]} {
    append sicon "ans"
    set alt "[string range $alt 0 0]A"
    append fullalt ", answered"
  }

  if {[string index $statbits 1]} {
    append sicon "del"
    set alt "[string range $alt 0 0]D"
    append fullalt ", deleted"
  }

  if {[info exists fullaltend]} {
    append fullalt $fullaltend
  } else {
    append fullalt message
  }

  regsub -all { } $alt {\&nbsp;} alt

  return [list [file join $_wp(imagepath) $_wp(staticondir) ${sicon}.${extension}] i_${uid} $alt $fullalt]
}

proc WPStatusLabel {uid} {
    global _wp

    set statbits [WPCmd PEMessage $uid statusbits]

    if {[string index $statbits 0]} {
      set sl new
    } else {
      set sl read
    }

    if {[string index $statbits 3]} {
      set sl important
    }

    if {[string index $statbits 1]} {
      set sl deleted
    }

    if {[string index $statbits 2]} {
      set sl answered
    }

    return $sl
}

proc WPStatusImg {uid} {
    set sicon [WPStatusIcon $uid]
    return [cgi_img [lindex $sicon 0] name=[lindex $sicon 1] id=[lindex $sicon 1] height=16 width=42 border=0 alt=[lindex $sicon 3]]
}

proc WPSessionState {args} {
  switch [llength $args] {
    1 -
    2 {
      if {[catch {WPCmd PEInfo alpinestate} state_list] == 0} {
	array set state_array $state_list
	if {[llength $args] == 1} {
	  return $state_array([lindex $args 0])
	} else {
	  set state_array([lindex $args 0]) [lindex $args 1]
	  set state_list [array get state_array]
	  if {[catch {WPCmd PEInfo alpinestate $state_list} result]} {
	    error "Can't set session state : $result"
	  }
	}
      } else {
	error "Can't read session state"
      }
    }
    default {
      error "Unknown SessionState Parameters: $args"
    }
  }
}

proc WPScriptVersion {tag {inc 0}} {
  if {[catch {WPCmd set wp_script_version} sv]} {
    set versions($tag) [expr int((1000 * rand()))]
    set sv [array get versions]
    catch {WPCmd set wp_script_version $sv}
  } else {
    array set versions $sv

    if {![info exists versions($tag)]} {
      set versions($tag) [expr int((1000 * rand()))]
      set sv [array get versions]
      catch {WPCmd set wp_script_version $sv}
    } elseif {$inc} {
      incr versions($tag) $inc
      set sv [array get versions]
      catch {WPCmd set wp_script_version $sv}
    }
  }

  return $versions($tag)
}

proc WPplural {count} {
    if {$count > 1} {
	return "s"
    }

    return ""
}

proc WPcomma {number {dot ,}} {
    set x ""

    while {[set n [string length $number]] > 3} {
	set x "${dot}[string range $number [incr n -3] end]$x"
	set number [string range $number 0 [incr n -1]]
    }

    return "$number$x"
}

proc isIE {} {
  global env

  return [expr {[info exists env(HTTP_USER_AGENT)] == 1 && [string first MSIE $env(HTTP_USER_AGENT)] >= 0}]
}

proc isW3C {} {
  global env

  return [expr {[info exists env(HTTP_USER_AGENT)] && (([regexp {^Mozilla/([0-9]).[0-9]+} $env(HTTP_USER_AGENT) match majorversion] && $majorversion > 4) || ([regexp {Opera ([0-9])\.[0-9]+} $env(HTTP_USER_AGENT) match majorversion] && $majorversion > 5))}]
}

proc WPdebug {args} {
    global _wp

    switch [lindex $args 0] {
      level {
	if {[regexp {^([0-9])+$} [lindex $args 1]]} {
	  WPSend $_wp(sockname) [subst {PEDebug level [lindex $args 1]}]
	}
      }
      imap {
	switch [lindex $args 1] {
	  on {
	    WPSend $_wp(sockname) [subst {ePEDebug imap 4}]
	  }
	  off {
	    WPSend $_wp(sockname) [subst {PEDebug imap 0}]
	  }
	}
      }
      default {
	WPSend $_wp(sockname) "PEDebug write [list [list [file tail [info script]]: [lrange $args 0 end]]]"
      }
    }
}

proc WPdebugstack {} {
    set stack {}

    for {set n [expr {[info level] - 1}]} {$n > 0} {incr n -1} {
	append stack "$n) [info level $n]\n"
    }
    return $stack
}


##############################################################
# routines to improve integration with cgi.tcl
##############################################################

# routine exposing some of cgi.tcl's innards.
# Should be exported by cgi.tcl package.
proc reset_cgi_state {} {
  global _cgi

  catch {unset _cgi(http_head_in_progress)}
  catch {unset _cgi(http_head_done)}
  catch {unset _cgi(http_status_done)}
  catch {unset _cgi(html_in_progress)}
  catch {unset _cgi(head_in_progress)}
  catch {unset _cgi(head_done)}
  catch {unset _cgi(html_done)}
  catch {unset _cgi(head_suppress_tag)}
  catch {unset _cgi(body_in_progress)}
  catch {unset _cgi(tag_in_progress)}
  catch {unset _cgi(form_in_progress)}
  catch {unset _cgi(close_proc)}

  if {[info exists _cgi(returnIndex)]} {
    while {[set _cgi(returnIndex)] > 0} {
      incr _cgi(returnIndex) -1
      rename cgi_puts ""
      rename cgi_puts$_cgi(returnIndex) cgi_puts
    }
  }
}

###############################################################
# routines to process (and be called in) html template files
###############################################################

proc html_readfile {file} {
    set x [open $file "r"]
    set result [read $x]
    close $x
    return $result
}

proc html_eval {_vars_ _this_} {
    foreach {_i_ _j_} $_vars_ {
	if {$_i_ == "global"} {global $_j_} {set $_i_ $_j_}
    }
    unset _vars_ _i_ _j_
    return [subst $_this_]
}

proc html_loop {varslist text} {
    set result ""
    foreach {vars} $varslist {
	append result [html_eval $vars $text]
    }
    return $result
}