git.rot13.org Git - webpac/blob - openisis/tcl/md

   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%>&nbsp;<% }
 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>