1 |
#!/opt/bin/tspr |
2 |
<%-- |
3 |
test Tcl server page |
4 |
$Id: md,v 1.3 2003/06/10 11:02:47 kripke Exp $ |
5 |
--%><%! |
6 |
|
7 |
package require mime; |
8 |
namespace import ::mime::*; |
9 |
|
10 |
# return list file from date subject size content-type |
11 |
proc mscan file { |
12 |
array set a {from {} date {} subject {} content-type {}} |
13 |
set fid [open $file] |
14 |
# for quick scan, ignore continuation lines and repeated headers |
15 |
while {[gets $fid line]} { |
16 |
if [regexp {^([\w\-]+):\s*(.*)} $line - key val] { |
17 |
set a([string tolower $key]) $val |
18 |
} |
19 |
} |
20 |
close $fid |
21 |
list $file $a(from) $a(date) $a(subject) [file size $file] $a(content-type) |
22 |
} |
23 |
|
24 |
# return list file from date subject size encoding content params parts msg |
25 |
proc mparse file { |
26 |
set l [list $file] |
27 |
set msg [initialize -file $file] |
28 |
# mime want's whole messages |
29 |
|
30 |
# headers |
31 |
foreach key {From Date Subject} { |
32 |
if [catch {getheader $msg $key} value] { |
33 |
lappend l {} |
34 |
} else { |
35 |
lappend l $value |
36 |
} |
37 |
} |
38 |
# properties (parsed content-* headers) |
39 |
foreach key {size encoding content params parts} { |
40 |
if [catch {getproperty $msg $key} value] { |
41 |
lappend l {} |
42 |
} else { |
43 |
lappend l $value |
44 |
} |
45 |
} |
46 |
lappend l $msg |
47 |
return $l |
48 |
} |
49 |
|
50 |
%><% |
51 |
# request standard tags |
52 |
# -10 SCRIPT_NAME |
53 |
# -11 PATH_INFO |
54 |
# -12 REMOTE_USER |
55 |
# |
56 |
# request parameters |
57 |
# 1 move destination (checkbox) |
58 |
# 2 the ok button |
59 |
# 3 write to |
60 |
# 4 write subject |
61 |
# 5 write body |
62 |
# |
63 |
global env |
64 |
# foreach e [array names env] { ::puts stderr "$e\t$env($e)" } |
65 |
::puts stderr [request serialize] |
66 |
|
67 |
set script [lindex [request get -10] 0] |
68 |
set path [lindex [request get -11] 0] |
69 |
set user [lindex [request get -12] 0] |
70 |
set body [lindex [request get 5] 0] |
71 |
|
72 |
if {"" == $user} return |
73 |
set l [string length $user] |
74 |
set fid [open /var/qmail/users/popasswd] |
75 |
while {[gets $fid line]} { |
76 |
if ![string match "$user:*" $line] continue |
77 |
set upignh [split $line :] |
78 |
set name [lindex $upignh 4] |
79 |
set base [lindex $upignh 5]/Maildir |
80 |
break |
81 |
} |
82 |
close $fid |
83 |
cd $base |
84 |
::puts stderr [pwd] |
85 |
|
86 |
if ![regexp {^/(\w+)(/\d+[\w.:,]*)?$} $path - dir file] { |
87 |
set dir new |
88 |
set file "" |
89 |
set rel $script/ |
90 |
} elseif {"" == $file} { |
91 |
set rel "" |
92 |
} else { |
93 |
set rel ../ |
94 |
} |
95 |
if ![file isdirectory $dir] return |
96 |
# scan for dirs |
97 |
set dirs {} ;# dirs to list |
98 |
set mvdirs {} ;# dirs to move to |
99 |
foreach d [glob ???] { |
100 |
if ![file isdirectory $d] continue |
101 |
switch -- $d tmp {} default { lappend dirs $d } |
102 |
switch -- $d new - tmp - uns - out - $dir {} default { lappend mvdirs $d } |
103 |
} |
104 |
if {"" != $body && [catch { # send |
105 |
set to [lindex [request get 3] 0] |
106 |
set subject [lindex [request get 4] 0] |
107 |
if {"" == $to} { # get from message |
108 |
set msg [initialize -file $dir$file] |
109 |
if [catch {getheader $msg Reply-To} to] { |
110 |
set to [getheader $msg From] |
111 |
} |
112 |
set to [lindex $to 0] |
113 |
if {"" == $subject} { |
114 |
set subject "Re: [lindex [getheader $msg Subject] 0]" |
115 |
} |
116 |
finalize $msg |
117 |
} |
118 |
set tim [clock seconds] |
119 |
set gtf [clock format $tim -format %Y%m%d%H%M%S -gmt 1] |
120 |
set rfc [clock format $tim -format {%a, %d %b %Y %H:%M:%S %Z}] |
121 |
set fid [open uns/$gtf.[pid] w] |
122 |
set msg [initialize -canonical text/plain \ |
123 |
-header [list Return-Path $name] \ |
124 |
-header [list From $name] \ |
125 |
-header [list To $to] \ |
126 |
-header [list Date $rfc] \ |
127 |
-header [list Subject $subject] \ |
128 |
-encoding quoted-printable \ |
129 |
-string $body ] |
130 |
copymessage $msg $fid |
131 |
close $fid |
132 |
}]} { |
133 |
global errorInfo |
134 |
::puts stderr $errorInfo |
135 |
} |
136 |
%><html> |
137 |
<head> |
138 |
</head> |
139 |
<body> |
140 |
<%"name%>/<%=dir%> |
141 |
list: |
142 |
<% |
143 |
foreach d $dirs { |
144 |
%> |
145 |
<a href="<%=$rel$d%>"><%=d%></a> |
146 |
<% |
147 |
} |
148 |
%> |
149 |
<%-- main display --%> |
150 |
<form action="<%=$rel$dir$file%>" method="POST"> |
151 |
<table> |
152 |
<% |
153 |
if {"" == $file} { |
154 |
%> |
155 |
<tr> |
156 |
<th> |
157 |
<% |
158 |
foreach d $mvdirs { %><%=d%> <% } |
159 |
%> |
160 |
</th> |
161 |
<th> |
162 |
From</th> |
163 |
<th>Date</th> |
164 |
<th>Size</th> |
165 |
<th>Subject</th> |
166 |
</tr> |
167 |
<% |
168 |
foreach mv [request get 1] { |
169 |
::puts stderr $mv |
170 |
if [regexp {^(\w\w\w)/(\S*)$} $mv - dest file] { |
171 |
file rename $dir/$file $dest |
172 |
%> |
173 |
<tr> |
174 |
<td>moved</td> |
175 |
<td><%"file%></td> |
176 |
<td>to</td> |
177 |
<td><%"dest%></td> |
178 |
</tr> |
179 |
<% |
180 |
} |
181 |
} |
182 |
cd $dir |
183 |
foreach f [glob *] { |
184 |
# file from date subject size content-type |
185 |
set l [mscan $f] |
186 |
%> |
187 |
<tr> |
188 |
<td> |
189 |
<% |
190 |
foreach d $mvdirs { |
191 |
%> |
192 |
<input type="checkbox" name="1" value="<%=d%>/<%?lindex $l 0%>"/> |
193 |
<% |
194 |
} |
195 |
%> |
196 |
</td> |
197 |
<td><%"lindex $l 1%></td> |
198 |
<td><%"lindex $l 2%></td> |
199 |
<td><%"lindex $l 4%></td> |
200 |
<td><a href="<%=dir%>/<%?lindex $l 0%>"><%"lindex $l 3%></a></td> |
201 |
</tr> |
202 |
<% |
203 |
} |
204 |
} else { # file view |
205 |
set msg [initialize -file $dir$file] |
206 |
foreach h [getheader $msg -names] { |
207 |
foreach v [getheader $msg $h] { |
208 |
%> |
209 |
<tr> |
210 |
<td><%"h%></td> |
211 |
<td><%"v%></td> |
212 |
</tr> |
213 |
<% |
214 |
} |
215 |
} |
216 |
set tpart "" |
217 |
if {"text/plain" == [getproperty $msg content]} { |
218 |
set tpart $msg |
219 |
} elseif {![catch {set parts [getproperty $msg parts]}]} { |
220 |
foreach p $parts { |
221 |
set ct [getproperty $p content] |
222 |
%> |
223 |
<tr> |
224 |
<td>part</td> |
225 |
<td><%"ct%></td> |
226 |
</tr> |
227 |
<% |
228 |
if {"text/plain" == $ct} { |
229 |
set tpart $p |
230 |
} |
231 |
} |
232 |
} |
233 |
if {"" != $tpart} { |
234 |
%> |
235 |
<tr><td colspan="2"><pre> |
236 |
<%"getbody $tpart%> |
237 |
</pre></td></tr> |
238 |
<% |
239 |
} |
240 |
} |
241 |
%> |
242 |
</table> |
243 |
<input type="submit" name="2" value="ok"/> |
244 |
<%-- send form --%> |
245 |
<table> |
246 |
<tr><td>to</td><td><input type="text" name="3" size="64"/></td></tr> |
247 |
<tr><td>subject</td><td><input type="text" name="4" size="64"/></td></tr> |
248 |
<tr><td colspan="2"> |
249 |
<textarea name="5" width="78" rows="20" cols="78"></textarea> |
250 |
</td></tr> |
251 |
</table> |
252 |
</form> |
253 |
</body> |
254 |
</html> |