1 |
dpavlin |
237 |
#!/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> |