xapian-applications/omega/rfc822tohtml.in

   1 #!@PERL@
   2 # @configure_input@
   3 # @file
   4 # @brief Extract HTML from an RFC-822 email
   5 #
   6 # Copyright (C) 2010,2015,2018,2019,2023 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 eval {
  59     eval {
  60         $date = Time::Piece->strptime($date, '%a, %d %b %Y %T %z');
  61     };
  62     # The "%a, " part is optional in RFC822 and RFC2822.
  63     $date = Time::Piece->strptime($date, '%d %b %Y %T %z') if $@;
  64     my $iso8601_date = $date->datetime;
  65     print "<meta name=\"created\" content=\"$iso8601_date\">\n";
  66 };
  67
  68 warn $@ if $@;
  69
  70 print "</head>\n";
  71
  72 handle_mimepart($ent);
  73
  74 sub do_header {
  75     my ($head, $header) = @_;
  76     my $s = MIME::WordDecoder::mime_to_perl_string($head->get($header, 0));
  77     chomp($s);
  78     return HTML::Entities::encode_entities($s);
  79 }
  80
  81 sub handle_mimepart {
  82     my $e = shift;
  83     my ($type, $sub) = ((lc $e->mime_type) =~ m,^(.*?)/(.*?)(?:;.*)?$,);
  84     if ($type eq 'multipart') {
  85         if ($sub eq 'alternative') {
  86             # Take the last mime part which we get text from.
  87             for my $s (reverse $e->parts) {
  88                 my $res = handle_mimepart($s);
  89                 return $res if $res;
  90             }
  91         } else {
  92             my $res = 0;
  93             for my $s ($e->parts) {
  94                 $res += handle_mimepart($s);
  95             }
  96             return $res;
  97         }
  98     } elsif ($type eq 'text') {
  99         if ($sub eq 'plain') {
 100             my $m = $e->bodyhandle->as_string;
 101             print "<pre>", HTML::Entities::encode_entities($m), "</pre>\n";
 102             return 1;
 103         } elsif ($sub eq 'html') {
 104             my $m = $e->bodyhandle->as_string;
 105             $m =~ s!</?body[^>]*>!\n!gi;
 106             print $m, "\n";
 107             return 1;
 108         }
 109     }
 110     return 0;
 111 }