xapian-applications/omega/rfc822tohtml.in

   1 #!@PERL@
   2 # @configure_input@
   3 # @file rfc822tohtml
   4 # @brief Extract HTML from an RFC-822 email
   5 #
   6 # Copyright (C) 2010,2015 Olly Betts
   7 #
   8 # Permission is hereby granted, free of charge, to any person obtaining a copy
   9 # of this software and associated documentation files (the "Software"), to
  10 # deal in the Software without restriction, including without limitation the
  11 # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
  12 # sell copies of the Software, and to permit persons to whom the Software is
  13 # furnished to do so, subject to the following conditions:
  14 #
  15 # The above copyright notice and this permission notice shall be included in
  16 # all copies or substantial portions of the Software.
  17 #
  18 # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  19 # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  20 # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  21 # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  22 # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  23 # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
  24 # IN THE SOFTWARE.
  25
  26 use strict;
  27 eval {
  28     require MIME::Parser;
  29     require MIME::WordDecoder;
  30     require HTML::Entities;
  31     # In core since Perl 5.9.5:
  32     require Time::Piece;
  33 };
  34 if ($@) {
  35     print STDERR $@;
  36     # Exit with code 127 which omindex interprets as "filter not installed"
  37     # and won't try further .msg files.
  38     exit 127;
  39 }
  40
  41 my $in = shift @ARGV;
  42 my $parser = new MIME::Parser;
  43 # Keep data in memory rather than spraying files onto disk.
  44 $parser->output_to_core(1);
  45 $parser->tmp_to_core(1);
  46 open IN, '<', $in or die "Couldn't open '$in' ($?)\n";
  47 my $ent = $parser->parse(\*IN) or die "Failed to parse '$in' as MIME message\n";
  48
  49 my $head = $ent->head;
  50 print "<head>\n<title>";
  51 print do_header($head, 'Subject');
  52 print "</title>\n<meta name=\"author\" content=\"";
  53 print do_header($head, 'From');
  54 print "\">\n";
  55
  56 my $date = do_header($head, 'Date');
  57 chomp $date;
  58 $date = Time::Piece->strptime($date, '%a, %d %b %Y %T %z');
  59 eval {
  60     my $iso8601_date = $date->datetime;
  61     print "<meta name=\"created\" content=\"$iso8601_date\">\n";
  62 };
  63
  64 print "</head>\n";
  65
  66 handle_mimepart($ent);
  67
  68 sub do_header {
  69     my ($head, $header) = @_;
  70     my $s = MIME::WordDecoder::mime_to_perl_string($head->get($header, 0));
  71     chomp($s);
  72     return HTML::Entities::encode_entities($s);
  73 }
  74
  75 sub handle_mimepart {
  76     my $e = shift;
  77     my ($type, $sub) = ((lc $e->mime_type) =~ m,^(.*?)/(.*?)(?:;.*)?$,);
  78     if ($type eq 'multipart') {
  79         if ($sub eq 'alternative') {
  80             # Take the first mime part which we get text from.
  81             for my $s ($e->parts) {
  82                 my $res = handle_mimepart($s);
  83                 return $res if $res;
  84             }
  85         } else {
  86             my $res = 0;
  87             for my $s ($e->parts) {
  88                 $res += handle_mimepart($s);
  89             }
  90             return $res;
  91         }
  92     } elsif ($type eq 'text') {
  93         if ($sub eq 'plain') {
  94             my $m = $e->bodyhandle->as_string;
  95             print "<pre>", HTML::Entities::encode_entities($m), "</pre>\n";
  96             return 1;
  97         } elsif ($sub eq 'html') {
  98             my $m = $e->bodyhandle->as_string;
  99             $m =~ s!</?body[^>]*>!\n!gi;
 100             print $m, "\n";
 101             return 1;
 102         }
 103     }
 104     return 0;
 105 }