home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Internet Tools 1993 July / Internet Tools.iso / RockRidge / mail / metamail / contrib / ServiceMail / src / services / get.tcl < prev    next >
Encoding:
Text File  |  1993-05-09  |  3.0 KB  |  90 lines

  1. # get
  2. #
  3. # 25-Jun-92 weber@eitech.com updated to new parameter format
  4. # 29-May-92 weber@eitech.com
  5. #
  6. # This service scans through a message body for postscript source, and
  7. # sends what it found to the printer.  If the input is a multipart, it
  8. # scans through the last body in the multipart.  It also does a check
  9. # to see if the address is local (it won't print otherwise).
  10. #
  11. # This service retrieves files from an archive.  Patterns describing
  12. # the desired files are in switches, or in the single body; all matching
  13. # archive files are bundled into the output message
  14. #
  15.  
  16. proc dofetch {switches envelope inputs} {
  17.     if {[llength $switches] == 0} {
  18.     set switches [exec cat [getfield $inputs FILE]]
  19.     if {[llength $switches] == 0} {set switches "info.txt"}
  20.     }
  21.     cd ~/archive
  22.     set hits {}
  23.     foreach pattern $switches {
  24.       set foo [glob -nocomplain $pattern]
  25. #Now we preprocess foo to make sure it doesn't have any verboten chars
  26.           if {
  27.                [string match /* $foo]||[string match ~* $foo]
  28.                ||[string match ../* $foo]||[regexp /../ $foo]
  29.                ||[string match  .\\./ $foo]||[regexp /.\\./ $foo]
  30.           } then {
  31. #Some sort of warning routine should go here...
  32.           } else { set hits [concat $hits $foo]}
  33.       
  34.      }
  35.     case [llength $hits] {
  36.     0 { setfield response STRING "No files found in archive that match \"$switches\"." }
  37.     1 {
  38.         if {[file readable $hits]} {
  39.           setfield response FILE $hits
  40.           setfield response DESCRIPTION "the archive file you requested"
  41.           setmimetype response
  42.         } {
  43.           setfield response STRING "Sorry, I could not retrieve the file $hits."
  44.         }
  45.     }
  46.     default {
  47.         setfield response TYPE multipart
  48.         setfield response SUBTYPE mixed
  49.         setfield response DESCRIPTION "the archive files you requested"
  50.         foreach hit $hits {
  51.           set part {}
  52.           if {[file readable $hit]} {
  53.         setfield part FILE $hit
  54.         setmimetype part
  55.           } {
  56.         setfield part STRING "Sorry, I could not retrieve the file $hit."
  57.           }
  58.           lappend parts $part
  59.         }
  60.         setfield response PARTS $parts
  61.     }
  62.     }
  63.     return [mailout [turnaround $envelope] $response]
  64. }
  65.  
  66. proc setmimetype {objectname} {
  67.     # set up filename as call-by-name
  68.     upvar $objectname object
  69.     set filename [getfield $object FILE]
  70.     case $filename {
  71.     *.ps { setfield object TYPE application; setfield object SUBTYPE postscript }
  72.     *.tex { setfield object TYPE text; setfield object SUBTYPE x-latex }
  73.     *.c { setfield object TYPE application; setfield object SUBTYPE x-c }
  74.     *.sh { setfield object TYPE application; setfield object SUBTYPE x-sh }
  75.     *.tar.Z { setfield object TYPE application
  76.           setfield object SUBTYPE octet-stream
  77.           setfield params name $filename
  78.           setfield params type tar
  79.           setfield params conversions compress
  80.           setfield object PARAMS $params
  81.         }
  82.     *.tar { setfield object TYPE application
  83.           setfield object SUBTYPE octet-stream
  84.           setfield params name $filename
  85.           setfield params type tar
  86.           setfield object PARAMS $params
  87.         }
  88.     }
  89. }
  90.