home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Internet Tools 1993 July / Internet Tools.iso / RockRidge / mail / metamail / contrib / ServiceMail / src / services / get-sumrn.tcl < prev    next >
Encoding:
Text File  |  1993-05-08  |  10.2 KB  |  364 lines
  1. # get-sumrn: an alternate version of get by Bob Sum (sumrn@dssv01.crd.ge.com)
  2. #
  3. # This service retrieve files from an archive.  Patterns describing the desired
  4. # files are in switches, or in the single body; all matching archive files are
  5. # bundled into the output message
  6. #
  7. #########################################################################
  8. #                                                                       #
  9. # Copyright (C) 1993 General Electric. All rights reserved.             #
  10. #                                                                       #
  11. # Permission to use, copy, modify, and distribute this                  #
  12. # software and its documentation for any purpose and without            #
  13. # fee is hereby granted, provided that the above copyright              #
  14. # notice appear in all copies and that both that copyright              #
  15. # notice and this permission notice appear in supporting                #
  16. # documentation, and that the name of General Electric not be used in   #
  17. # advertising or publicity pertaining to distribution of the            #
  18. # software without specific, written prior permission.                  #
  19. #                                                                       #
  20. # General Electric makes no representations about the suitability of    #
  21. # this software for any purpose.  It is provided ``as is''              #
  22. # without express or implied warranty.                                  #
  23. #                                                                       #
  24. # This work was supported by the DARPA Initiative in Concurrent         #
  25. # Engineering (DICE) through DARPA Contract MDA972-92-C-0027.           #
  26. #                                                                       #
  27. #########################################################################
  28. #
  29. # Enhancements initially by Robert Sum (sumrn@crd.ge.com) for the
  30. # Microwave and Millimeter-wave Pilot Sites (MMPS) DICE program.
  31. #
  32. # $Id: archive-request.tcl,v 1.8 1993/02/16 01:18:39 sumrn Exp $
  33. #
  34. # $Log: archive-request.tcl,v $
  35. # Revision 1.8  1993/02/16  01:18:39  sumrn
  36. # Files are returned in alpha sorted order.
  37. #
  38. # Revision 1.7  1993/02/15  17:25:49  sumrn
  39. # New setmimetype (with audio).
  40. #
  41. # Revision 1.6  1993/02/10  21:02:53  sumrn
  42. # Just starting to periodically include my setmimetype from ArchiveServices.
  43. # It has more type stuff in it.
  44. #
  45. # Revision 1.5  1993/02/10  15:41:31  sumrn
  46. # Added file extension recognition to for gif and jp[e]g.
  47. #
  48. # Revision 1.4  1993/02/09  22:10:45  sumrn
  49. # Enhanced setmimetype with respect to C, Fortran, tcl, and a couple others
  50. # to add name of the originating file and use x-subtype.
  51. #
  52. # Revision 1.3  1993/01/22  23:37:00  sumrn
  53. # 1. Fixed a bug where switches/request from body were not handled
  54. # properly.  (My own bug.)
  55. #
  56. # Revision 1.2  1993/01/22  19:08:55  sumrn
  57. # 1. Enhanced the error messages returned to the requestor so that
  58. # if anything file searches go wrong he is notified.
  59. # (The only exception might be special devices, but there should not be
  60. # any of those in the archive anyway, right?)
  61. # 2. Fixed bug of trying to send non-existent files which would happen
  62. # if a fixed string is handed to glob.
  63. # 3. Enhanced (I think at the moment anyway) the error checking for patterns
  64. # that try to stray outside the archive for files.
  65. #
  66. #
  67.  
  68. proc dofetch {switches envelope inputs} {
  69.  
  70.     set messages ""
  71.  
  72.     #
  73.     # if no switches in subject, get from body--if any.
  74.     #
  75.     if {[llength $switches] == 0} {
  76.         set switches [exec cat [getfield $inputs FILE]]
  77.     }
  78.  
  79.     #
  80.     # Determine request, use info.txt if no switches
  81.     #
  82.     set request $switches
  83.     if {[llength $request] == 0} then {
  84.         set request "info.txt"
  85.         set messages \
  86.             "$messages\nNo specific request:  Sending information."
  87.     }
  88.  
  89.     #
  90.     # change to archive directory
  91.     #
  92.     cd ~/archive
  93.  
  94.     #
  95.     # check that files are within the archive
  96.     #
  97.     set hits {}
  98.     foreach pattern $request {
  99.  
  100.         #
  101.         # check obvious straying outside the archive
  102.         #
  103.         if { [string match /* $pattern]
  104.                 || [string match ~* $pattern]
  105.                 || [string match ../* $pattern]
  106.                 || [regexp /\.\./ $pattern]
  107.         } then {
  108.             set messages \
  109.             "$messages\nImproper pattern:  $pattern."
  110.             continue
  111.         }
  112.  
  113.         #
  114.         # expand to almost get the actual files
  115.         #
  116.         set expansions [glob -nocomplain $pattern]
  117.         if { $expansions == {} } then {
  118.             set messages \
  119.                 "$messages\nNo match: $pattern."
  120.             continue
  121.         }
  122.  
  123.         #
  124.         # check for not so obvious wandering
  125.         #
  126.         foreach expan $expansions {
  127.             # check straying outside the archive
  128.             if { [string match /* $expan]
  129.                     || [string match ../* $expan]
  130.                     || [regexp /\.\./ $expan]
  131.             } then {
  132.                 set messages \
  133.                 "$messages\nImproper pattern:  $pattern."
  134.                 break
  135.             }
  136.             set hits [concat $hits $expan]
  137.         }
  138.     }
  139.  
  140.     #
  141.     # check that files exist and are processable:
  142.     #   globbing without pattern can let non-file through, and
  143.     #   only simple files can be sent.
  144.     #
  145.     set filelist {}
  146.     foreach h $hits {
  147.         if {![file exists $h] } then {
  148.             set messages \
  149.                 "$messages\nNo such file: $h."
  150.             continue
  151.         }
  152.         if {![file isfile $h]} then {
  153.             set messages \
  154.                 "$messages\nFile can not be processed: $h."
  155.             continue
  156.         }
  157.         set filelist [concat $filelist $h]
  158.     }
  159.  
  160.     #
  161.     # Note:  One could regard returning error messages about searches
  162.     #   as a security risk.  The messages here take a modest effort
  163.     #   to use to determine file existence external to the archive.
  164.     #   Benevolent users will much appreciate them, however.
  165.     #
  166.     set filelist [lsort $filelist]
  167.     case [llength $filelist] {
  168.     0 {
  169.         setfield response DESCRIPTION "No files filled your request."
  170.         set messages "$messages\nEnd of messages.\n"
  171.         setfield response \
  172.             STRING "Messages for request: $switches.\n$messages"
  173.     }
  174.     1 {
  175.         setfield response DESCRIPTION "the archive file you requested"
  176.         if { $messages != "" } then {
  177.  
  178.             set messages "$messages\nEnd of messages.\n"
  179.  
  180.             setfield response TYPE multipart
  181.             setfield response SUBTYPE mixed
  182.             set parts {}
  183.  
  184.             set part {}
  185.             setfield part TYPE text
  186.             setfield part STRING \
  187.                 "Messages for request: $switches.\n$messages"
  188.             lappend parts $part
  189.  
  190.             set part {}
  191.             setfield part FILE $filelist
  192.             setmimetype part
  193.             lappend parts $part
  194.  
  195.             setfield response PARTS $parts
  196.         } else {
  197.             setfield response FILE $filelist;
  198.             setmimetype response
  199.         }
  200.     }
  201.     default {
  202.         setfield response TYPE multipart
  203.         setfield response SUBTYPE mixed
  204.         setfield response DESCRIPTION "the archive files you requested"
  205.         set parts {}
  206.         if { $messages != "" } then {
  207.  
  208.             set messages "$messages\nEnd of messages.\n"
  209.  
  210.             set part {}
  211.             setfield part TYPE text
  212.             setfield part STRING \
  213.                 "Messages for request: $switches.\n$messages"
  214.             lappend parts $part
  215.         }
  216.         foreach f $filelist {
  217.             set part {}
  218.             setfield part FILE $f
  219.             setmimetype part
  220.             lappend parts $part
  221.         }
  222.         setfield response PARTS $parts
  223.     }
  224.     }
  225.  
  226.     return [mailout [turnaround $envelope] $response]
  227. }
  228.  
  229. # Id: setmimetype.tcl,v 1.5 1993/02/15 17:22:12 sumrn Exp
  230. #
  231. # Enhancements initially by Robert Sum (sumrn@crd.ge.com) for the
  232. # Microwave and Millimeter-wave Pilot Sites (MMPS) DICE program.
  233. #
  234. #
  235. # Log: setmimetype.tcl,v
  236. # Revision 1.5  1993/02/15  17:22:12  sumrn
  237. # Added audio type to filename typing.
  238. #
  239. # Revision 1.4  1993/02/10  20:35:49  sumrn
  240. # Added type information for Express (*.exp,text/x-express),
  241. # tex dvi output  (*.dvi,image/x-dvi), Framemaker (*.mif,text/x-frame),
  242. # and AutoCAD dxf (*.dxf,text/x-dxf).
  243. #
  244. # Revision 1.3  1993/02/10  15:44:03  sumrn
  245. # Added file extension recognition to for gif and jp[e]g.
  246. #
  247. # Revision 1.2  1993/02/09  22:22:25  sumrn
  248. # Enhanced setmimetype with respect to C, Fortran, tcl, and a couple others
  249. # to add name of the originating file and use x-subtype.
  250. #
  251. # Revision 1.1  1993/02/04  19:43:09  sumrn
  252. # Initial revision
  253. #
  254. # setmimetype
  255. #   sets the appropriate type information for a file.
  256. #   input is the name of a variable that contains a message part needed
  257. #   type information.
  258. #
  259. proc setmimetype {objectname} {
  260.  
  261.     # set up filename as call-by-name
  262.     upvar $objectname object
  263.  
  264.     set filename [getfield $object FILE]
  265.     case $filename {
  266.     *.au {
  267.         setfield object TYPE audio
  268.         setfield object SUBTYPE basic
  269.         setfield params name $filename
  270.         setfield object PARAMS $params
  271.     }
  272.     *.c {
  273.         setfield object TYPE text
  274.         setfield object SUBTYPE x-c
  275.         setfield params charset us-ascii
  276.         setfield params name $filename
  277.         setfield object PARAMS $params
  278.     }
  279.     *.dvi {
  280.         setfield object TYPE image
  281.         setfield object SUBTYPE x-dvi
  282.         setfield params name $filename
  283.         setfield object PARAMS $params
  284.     }
  285.     *.dxf {
  286.         setfield object TYPE text
  287.         setfield object SUBTYPE x-dxf
  288.         setfield params charset us-ascii
  289.         setfield params name $filename
  290.         setfield object PARAMS $params
  291.     }
  292.     *.exp {
  293.         setfield object TYPE text
  294.         setfield object SUBTYPE x-express
  295.         setfield params charset us-ascii
  296.         setfield params name $filename
  297.         setfield object PARAMS $params
  298.     }
  299.     {*.f *.ftn} {
  300.         setfield object TYPE text
  301.         setfield object SUBTYPE x-fortran
  302.         setfield params charset us-ascii
  303.         setfield params name $filename
  304.         setfield object PARAMS $params
  305.     }
  306.     {*.GIF *.gif} {
  307.         setfield object TYPE image
  308.         setfield object SUBTYPE gif
  309.         setfield params name $filename
  310.         setfield object PARAMS $params
  311.     }
  312.     {*.JPG *.JPEG *.jpg *.jpeg} {
  313.         setfield object TYPE image
  314.         setfield object SUBTYPE jpeg
  315.         setfield params name $filename
  316.         setfield object PARAMS $params
  317.     }
  318.     *.mif {
  319.         setfield object TYPE text
  320.         setfield object SUBTYPE x-frame
  321.         setfield params charset us-ascii
  322.         setfield params name $filename
  323.         setfield object PARAMS $params
  324.     }
  325.     *.ps {
  326.         setfield object TYPE application
  327.         setfield object SUBTYPE postscript
  328.     }
  329.     *.sh {
  330.         setfield object TYPE application
  331.         setfield object SUBTYPE x-sh
  332.     }
  333.     *.tar.Z {
  334.         setfield object TYPE application
  335.         setfield object SUBTYPE octet-stream
  336.         setfield params name $filename
  337.         setfield params type tar
  338.         setfield params conversions compress
  339.         setfield object PARAMS $params
  340.     }
  341.     *.tar {
  342.         setfield object TYPE application
  343.         setfield object SUBTYPE octet-stream
  344.         setfield params name $filename
  345.         setfield params type tar
  346.         setfield object PARAMS $params
  347.     }
  348.     *.tex {
  349.         setfield object TYPE text
  350.         setfield object SUBTYPE x-latex
  351.         setfield params charset us-ascii
  352.         setfield params name $filename
  353.         setfield object PARAMS $params
  354.     }
  355.     *.tcl {
  356.         setfield object TYPE text
  357.         setfield object SUBTYPE x-tcl
  358.         setfield params charset us-ascii
  359.         setfield params name $filename
  360.         setfield object PARAMS $params
  361.     }
  362.     }
  363. }
  364.