user-tools/mail-extract-raw-headers

   1 #!/usr/bin/env perl
   2
   3 =pod
   4
   5 =head1 NAME
   6
   7 mail-extract-raw-headers - Get named headers from RFC822-format input.
   8
   9 =head1 SYNOPSIS
  10
  11 mail-extract-raw-headers [OPTIONS] <NAME> [<NAME> [...]]
  12
  13 =head1 OPTIONS
  14
  15 =over 4
  16
  17 =item -k, --keep-newlines, --keep-linefeeds
  18
  19 Keep linefeeds in multiline text.
  20
  21 =item -n, --header-names
  22
  23 Output the header name(s) too, not only the contents.
  24
  25 =back
  26
  27 =cut
  28
  29
  30 use Getopt::Long qw/:config no_ignore_case bundling no_getopt_compat/;
  31 use Pod::Usage;
  32 use Data::Dumper;
  33 no if ($] >= 5.018), 'warnings' => 'experimental::smartmatch';
  34
  35 $OptKeepLF = 0;
  36 $OptNames = 0;
  37
  38 GetOptions(
  39         'k|keep-newlines|keep-linefeeds' => \$OptKeepLF,
  40         'n|header-names' => \$OptNames,
  41         'help|?' => sub { pod2usage(-exitval=>0, -verbose=>99); },
  42 ) or pod2usage(-exitval=>2, -verbose=>99);
  43
  44 if(not @ARGV)
  45 {
  46         pod2usage(-exitval=>2, -verbose=>99);
  47 }
  48
  49 @asked_headers = map {lc} @ARGV;
  50
  51
  52 sub getheaders($)
  53 {
  54         my $hname = lc shift;
  55         my @return;
  56
  57         for my $header_ref (@Headers)
  58         {
  59                 if(lc $header_ref->{"name"} eq $hname)
  60                 {
  61                         push @return, $header_ref->{"content"};
  62                 }
  63         }
  64         return @return;
  65 }
  66
  67 %found_headers = ();
  68
  69 # read headers
  70 while(<STDIN>)
  71 {
  72         if(/^\r?\n?$/)
  73         {
  74                 # End of Headers
  75                 last;
  76         }
  77
  78         # does not care line ending
  79         s/\r?\n?$//;
  80
  81         if(my($header_name, $content) = /^(\S+?):[ ]?(.*)/)
  82         {
  83                 if(lc $header_name ~~ @asked_headers)
  84                 {
  85                         my $header_name_pretty = $header_name =~ s/[^-]*/\L\u$&/gr;
  86                         my $header_hash = { "name" => $header_name, "pretty_name" => $header_name_pretty, "content" => $content, };
  87                         push @{$found_headers{lc $header_name}}, $header_hash;
  88                         $last_header_ref = $header_hash;
  89                 }
  90                 else
  91                 {
  92                         $last_header_ref = undef;
  93                 }
  94         }
  95         elsif(/^\s+(.*)/)
  96         {
  97                 # it is a folded header
  98                 if(defined $last_header_ref)
  99                 {
 100                         $last_header_ref->{"content"} .= "\n" if $OptKeepLF;
 101                         $last_header_ref->{"content"} .= $1;
 102                 }
 103         }
 104         else
 105         {
 106                 die "$0: can not parse line $.\n";
 107         }
 108 }
 109
 110 for my $asked_header (@asked_headers)
 111 {
 112         for my $header (@{$found_headers{$asked_header}})
 113         {
 114                 # avoid non-whitespace character at the beginning of lines in the header content,
 115                 # so header names can not be spoofed.
 116                 my $safe_content = $header->{'content'} =~ s/\n([^\t ])/\n  $1/gr;
 117
 118                 if($OptNames)
 119                 {
 120                         printf "%s: %s\n", $header->{'name'}, $safe_content;
 121                 }
 122                 else
 123                 {
 124                         printf "%s\n", $safe_content;
 125                 }
 126         }
 127 }