home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Header.pm < prev    next >
Encoding:
Perl POD Document  |  2003-09-22  |  20.3 KB  |  1,013 lines

  1. # Mail::Header.pm
  2. #
  3. # Copyright (c) 1995-2001 Graham Barr <gbarr@pobox.com>. All rights reserved.
  4. # Copyright (c) 2002-2003 Mark Overmeer <mailtools@overmeer.net>
  5. # This program is free software; you can redistribute it and/or
  6. # modify it under the same terms as Perl itself.
  7.  
  8. #
  9. # The internals of this package are implemented in terms of a list of lines
  10. # and a hash indexed by the tags. The hash contains a list of references to
  11. # the actual SV's in the list. We therefore do our upmost to preserve this.
  12. # anyone who delves into these structures deserve all they get.
  13. #
  14.  
  15. package Mail::Header;
  16.  
  17. require 5.002;
  18.  
  19. use strict;
  20. use Carp;
  21. use vars qw($VERSION $FIELD_NAME);
  22.  
  23. $VERSION = "1.60";
  24.  
  25. my $MAIL_FROM = 'KEEP';
  26. my %HDR_LENGTHS = ();
  27.  
  28. #
  29. # Pattern to match a RFC822 Field name ( Extract from RFC #822)
  30. #
  31. #     field       =  field-name ":" [ field-body ] CRLF
  32. #
  33. #     field-name  =  1*<any CHAR, excluding CTLs, SPACE, and ":">
  34. #
  35. #     CHAR        =  <any ASCII character>        ; (  0-177,  0.-127.)
  36. #     CTL         =  <any ASCII control           ; (  0- 37,  0.- 31.)
  37. #              character and DEL>          ; (    177,     127.)
  38. # I have included the trailing ':' in the field-name
  39. #
  40. $FIELD_NAME = '[^\x00-\x1f\x7f-\xff :]+:';
  41.  
  42. ##
  43. ## Private functions
  44. ##
  45.  
  46. sub _error { warn @_; return (wantarray ? () : undef) }
  47.  
  48. # tidy up internal hash table and list
  49.  
  50. sub _tidy_header
  51. {
  52.  my $me = shift;
  53.  my($ref,$key);
  54.  my $i;
  55.  my $d = 0;
  56.  
  57.  for($i = 0 ; $i < scalar(@{$me->{'mail_hdr_list'}}) ; $i++)
  58.   {
  59.    unless(defined $me->{'mail_hdr_list'}[$i])
  60.     {
  61.      splice(@{$me->{'mail_hdr_list'}},$i,1);
  62.      $d++;
  63.      $i--;
  64.     }
  65.   }
  66.  
  67.  if($d)
  68.   {
  69.    local $_;
  70.    my @del = ();
  71.  
  72.    while(($key,$ref) = each %{$me->{'mail_hdr_hash'}} )
  73.     {
  74.      push(@del, $key)
  75.     unless @$ref = grep { ref($_) && defined $$_ } @$ref;
  76.     }
  77.  
  78.    map { delete $me->{'mail_hdr_hash'}{$_} } @del;
  79.   }
  80. }
  81.  
  82. # fold the line to the given length
  83.  
  84. my %STRUCTURE;
  85. @STRUCTURE{ map { lc } qw{
  86.   To Cc Bcc From Date Reply-To Sender
  87.   Resent-Date Resent-From Resent-Sender Resent-To Return-Path
  88.   list-help list-post list-unsubscribe Mailing-List
  89.   Received References Message-ID In-Reply-To
  90.   Content-Length Content-Type Content-Disposition
  91.   Delivered-To
  92.   Lines
  93.   MIME-Version
  94.   Precedence
  95.   Status
  96. }} = ();
  97.  
  98. sub _fold_line
  99. {
  100.  my($ln,$maxlen) = @_;
  101.  
  102.  $maxlen = 20
  103.     if($maxlen < 20);
  104.  
  105.  my $max = int($maxlen - 5);         # 4 for leading spcs + 1 for [\,\;]
  106.  my $min = int($maxlen * 4 / 5) - 4;
  107.  my $ml = $maxlen;
  108.  
  109.  $_[0] =~ s/\s*[\r\n]+\s*/ /og; # Compress any white space around a newline
  110.  $_[0] =~ s/\s*\Z/\n/so;        # End line with a EOLN
  111.  
  112.  return if $_[0] =~ /^From\s/io;
  113.  
  114.  if(length($_[0]) > $ml)
  115.   {
  116.    if ($_[0] =~ /^([-\w]+)/ && exists $STRUCTURE{ lc $1 } )
  117.     {
  118.      #Split the line up
  119.      # first bias towards splitting at a , or a ; >4/5 along the line
  120.      # next split a whitespace
  121.      # else we are looking at a single word and probably don't want to split
  122.      my $x = "";
  123.  
  124.      $x .= "$1\n    "
  125.     while($_[0] =~ s/^\s*(
  126.                [^"]{$min,$max}?[\,\;]
  127.               |[^"]{1,$max}\s
  128.               |[^\s"]*(?:"[^"]*"[^\s"]*)+\s
  129.               |[^\s"]+\s
  130.               )
  131.             //x);
  132.      $x .= $_[0];
  133.      $_[0] = $x;
  134.      $_[0] =~ s/(\A\s+|[\t ]+\Z)//sog;
  135.      $_[0] =~ s/\s+\n/\n/sog;
  136.     }
  137.    else
  138.     {
  139.       $_[0] =~ s/(.{$min,$max})\s+/$+\n    /g;
  140.       $_[0] =~ s/\s*$/\n/s;
  141.     }
  142.   }
  143.  
  144.  $_[0] =~ s/\A(\S+)\n\s*(?=\S)/$1 /so; 
  145. }
  146.  
  147. # attempt to change the case of a tag to that required by RFC822. That
  148. # being all characters are lowercase except the first of each word. Also
  149. # if the word is an `acronym' then all characters are uppercase. We decide
  150. # a word is an acronym if it does not contain a vowel.
  151.  
  152. sub _tag_case
  153. {
  154.  my $tag = shift;
  155.  $tag =~ s/\:$//;
  156.  
  157.  join('-',
  158.      map { /^[b-df-hj-np-tv-z]+$|^(?:MIME|SWE|SOAP|LDAP)$/i
  159.          ? uc($_) : ucfirst(lc($_)) }
  160.               split('-', $tag));
  161. }
  162.  
  163. # format a complete line
  164. #  ensure line starts with the given tag
  165. #  ensure tag is correct case
  166. #  change the 'From ' tag as required
  167. #  fold the line
  168.  
  169. sub _fmt_line
  170. {
  171.  my $me = shift;
  172.  my $tag = shift;
  173.  my $line = shift;
  174.  my $modify = shift || $me->{'mail_hdr_modify'};
  175.  my $ctag = undef;
  176.  
  177.  ($tag) = $line =~ /\A($FIELD_NAME|From )/oi
  178.     unless(defined $tag);
  179.  
  180.  if($tag =~ /\AFrom /io && $me->{'mail_hdr_mail_from'} ne 'KEEP')
  181.   {
  182.    if ($me->{'mail_hdr_mail_from'} eq 'COERCE')
  183.     {
  184.      $line =~ s/^From /Mail-From: /o;
  185.      $tag = "Mail-From:";
  186.     }
  187.    elsif ($me->{'mail_hdr_mail_from'} eq 'IGNORE')
  188.     {
  189.      return ();
  190.     }
  191.    elsif ($me->{'mail_hdr_mail_from'} eq 'ERROR')
  192.     {
  193.      return _error "unadorned 'From ' ignored: <$line>"
  194.     }
  195.   }
  196.  
  197.  if(defined $tag)
  198.   {
  199.    $tag = _tag_case($ctag = $tag);
  200.  
  201.    $ctag = $tag
  202.        if($modify);
  203.  
  204.    $ctag =~ s/([^ :])\Z/$1:/o if defined $ctag;
  205.   }
  206.  
  207.  croak( "Bad RFC822 field name '$tag'\n")
  208.    unless(defined $ctag && $ctag =~ /\A($FIELD_NAME|From )/oi);
  209.  
  210.  # Ensure the line starts with tag
  211.  if(defined($ctag) && ($modify || $line !~ /\A\Q$ctag\E/i))
  212.   {
  213.    my $xtag;
  214.    ($xtag = $ctag) =~ s/\s*\Z//o;
  215.    $line =~ s/\A(\Q$ctag\E)?\s*/$xtag /i;
  216.   }
  217.  
  218.  my $maxlen = $me->{'mail_hdr_lengths'}{$tag}
  219.         || $HDR_LENGTHS{$tag}
  220.         || $me->fold_length;
  221.  
  222.  _fold_line($line,$maxlen)
  223.     if $modify && defined $maxlen;
  224.  
  225.  $line =~ s/\n*\Z/\n/so;
  226.  
  227.  ($tag, $line);
  228. }
  229.  
  230. sub _insert
  231. {
  232.  my($me,$tag,$line,$where) = @_;
  233.  
  234.  if($where < 0)
  235.   {
  236.    $where = @{$me->{'mail_hdr_list'}} + $where + 1;
  237.  
  238.    $where = 0
  239.     if($where < 0);
  240.   }
  241.  elsif($where >= @{$me->{'mail_hdr_list'}})
  242.   {
  243.    $where = @{$me->{'mail_hdr_list'}};
  244.   }
  245.  
  246.  my $atend = $where == @{$me->{'mail_hdr_list'}};
  247.  
  248.  splice(@{$me->{'mail_hdr_list'}},$where,0,$line);
  249.  
  250.  $me->{'mail_hdr_hash'}{$tag} ||= [];
  251.  my $ref = \${$me->{'mail_hdr_list'}}[$where];
  252.  
  253.  if($me->{'mail_hdr_hash'}{$tag} && $where)
  254.   {
  255.    if($atend)
  256.     {
  257.      push(@{$me->{'mail_hdr_hash'}{$tag}}, $ref);
  258.     }
  259.    else
  260.     {
  261.      my $i = 0;
  262.      foreach my $ln (@{$me->{'mail_hdr_list'}})
  263.       {
  264.        my $r = \$ln;
  265.        last if($r == $ref);
  266.        $i++ if($r == $me->{'mail_hdr_hash'}{$tag}[$i]);
  267.       }
  268.      splice(@{$me->{'mail_hdr_hash'}{$tag}},$i,0,$ref);
  269.     }
  270.   }
  271.  else
  272.   {
  273.    unshift(@{$me->{'mail_hdr_hash'}{$tag}}, $ref);
  274.   }
  275. }
  276.  
  277. ##
  278. ## Constructor
  279. ##
  280.  
  281. sub new
  282. {
  283.  my $self = shift;
  284.  my $type = ref($self) || $self;
  285.  my $arg = @_ % 2 ? shift : undef;
  286.  my %arg = @_;
  287.  
  288.  $arg{Modify} = delete $arg{Reformat} unless exists $arg{Modify};
  289.  
  290.  my %hash = (
  291.     mail_hdr_list     => [],
  292.     mail_hdr_hash     => {},
  293.     mail_hdr_modify   => delete $arg{Modify} || 0,
  294.     mail_hdr_foldlen  => 79,
  295.     mail_hdr_lengths  => {}
  296.     );
  297.  
  298.  my $me = bless \%hash, $type;
  299.  
  300.  $me->mail_from( uc($arg{'MailFrom'} || $MAIL_FROM) );
  301.  
  302.  $me->fold_length($arg{FoldLength})
  303.     if exists $arg{FoldLength};
  304.  
  305.  if(ref $arg)
  306.   {
  307.    if(ref($arg) eq 'ARRAY')
  308.     {
  309.      $me->extract([ @{$arg} ]);
  310.     }
  311.    elsif(defined fileno($arg))
  312.     {
  313.      $me->read($arg);
  314.     }
  315.   }
  316.  
  317.  $me;
  318. }
  319.  
  320. sub modify
  321. {
  322.  my $me = shift;
  323.  my $old = $me->{'mail_hdr_modify'};
  324.  
  325.  $me->{'mail_hdr_modify'} = 0 + shift
  326.     if @_;
  327.  
  328.  $old;
  329. }
  330.  
  331. sub mail_from
  332. {
  333.  my $me = shift;
  334.  my $choice = uc(shift);
  335.  
  336.  $choice =~ /^(IGNORE|ERROR|COERCE|KEEP)$/ 
  337.     or die "bad Mail-From choice: '$choice'";
  338.  
  339.  if(ref($me))
  340.   {
  341.    $me->{'mail_hdr_mail_from'} = $choice;
  342.   }
  343.  else
  344.   {
  345.    $MAIL_FROM = $choice;
  346.   }
  347.  
  348.  $me;
  349. }
  350.  
  351. sub fold
  352. {
  353.  my $me = shift;
  354.  my $maxlen = shift;
  355.  my($tag,$list,$ln);
  356.  
  357.  while(($tag,$list) = each %{$me->{'mail_hdr_hash'}})
  358.   {
  359.    my $len = $maxlen
  360.         || $me->{'mail_hdr_lengths'}{$tag}
  361.         || $HDR_LENGTHS{$tag}
  362.         || $me->fold_length;
  363.  
  364.    foreach $ln (@$list)
  365.     {
  366.      _fold_line($$ln,$len)
  367.         if defined $ln;
  368.     }
  369.   }
  370.  
  371.  $me;
  372. }
  373.  
  374. sub unfold
  375. {
  376.  my $me = shift;
  377.  my($tag,$list,$ln);
  378.  
  379.  if(@_)
  380.   {
  381.    $tag = _tag_case(shift);
  382.    return $me unless exists $me->{'mail_hdr_hash'}{$tag};
  383.    $list = $me->{'mail_hdr_hash'}{$tag};
  384.    foreach $ln (@$list)
  385.     {
  386.      $$ln =~ s/\r?\n\s+/ /sog
  387.     if defined $ln && defined $$ln;
  388.     }
  389.   }
  390.  else
  391.   {
  392.    while(($tag,$list) = each %{$me->{'mail_hdr_hash'}})
  393.     {
  394.      foreach $ln (@$list)
  395.       {
  396.        $$ln =~ s/\r?\n\s+/ /sog
  397.     if defined $ln && defined $$ln;
  398.       }
  399.     }
  400.   }
  401.  $me;
  402. }
  403.  
  404. sub extract
  405. {
  406.  my $me = shift;
  407.  my $arr = shift;
  408.  my $line;
  409.  
  410.  $me->empty;
  411.  
  412.  while(scalar(@{$arr}) && $arr->[0] =~ /\A($FIELD_NAME|From )/o)
  413.   {
  414.    my $tag = $1;
  415.  
  416.    $line = shift @{$arr};
  417.    $line .= shift @{$arr}
  418.        while(scalar(@{$arr}) && $arr->[0] =~ /\A[ \t]+/o);
  419.  
  420.    ($tag,$line) = _fmt_line($me,$tag,$line);
  421.  
  422.    _insert($me,$tag,$line,-1)
  423.       if defined $line;
  424.   }
  425.  
  426.  shift @{$arr}
  427.   if(scalar(@{$arr}) && $arr->[0] =~ /\A\s*\Z/o);
  428.  
  429.  $me;
  430. }
  431.  
  432. sub read
  433. {
  434.  my $me = shift;
  435.  my $fd = shift;
  436.  
  437.  $me->empty;
  438.  
  439.  my $line = undef;
  440.  my $ln = "";
  441.  my $tag = undef;
  442.  
  443.  while(1)
  444.   {
  445.    $ln = <$fd>;
  446.  
  447.    if(defined $ln && defined $line && $ln =~ /\A[ \t]+/o)
  448.     {
  449.      $line .= $ln;
  450.      next;
  451.     }
  452.  
  453.    if(defined $line)
  454.     {
  455.      ($tag,$line) = _fmt_line($me,$tag,$line);
  456.       _insert($me,$tag,$line,-1)
  457.     if defined $line;
  458.     }
  459.  
  460.    last
  461.      unless(defined $ln && $ln =~ /\A($FIELD_NAME|From )/o);
  462.  
  463.    $tag  = $1;
  464.    $line = $ln;
  465.   }
  466.  
  467.  $me;
  468. }
  469.  
  470. sub empty
  471. {
  472.  my $me = shift;
  473.  
  474.  $me->{'mail_hdr_list'} = [];
  475.  $me->{'mail_hdr_hash'} = {};
  476.  
  477.  $me;
  478. }
  479.  
  480. sub header
  481. {
  482.  my $me = shift;
  483.  
  484.  $me->extract(@_)
  485.     if(@_);
  486.  
  487.  $me->fold
  488.     if $me->{'mail_hdr_modify'};
  489.  
  490.  # Must protect ourself against corruption as the hash contains refs to the
  491.  # SV's in the list, if the user modifies this list we are really screwed :-
  492.  
  493.  [ @{$me->{'mail_hdr_list'}} ];
  494. }
  495.  
  496. # Return/set headers by hash reference.  This can probably be
  497. # optimized. I didn't want to mess much around with the internal
  498. # implementation as for now...
  499. # -- Tobias Brox <tobix@cpan.org>
  500.  
  501. sub header_hashref {
  502.  my $me = shift;
  503.  my $hashref = shift;
  504.  
  505.  # Extract the input data
  506.  for my $hdrkey (keys %$hashref) {
  507.    for (ref $hashref->{$hdrkey} 
  508.     ? @{$hashref->{$hdrkey}} 
  509.     : $hashref->{$hdrkey}) {
  510.      $me->add($hdrkey, $_);
  511.    }
  512.  }
  513.  
  514.  $me->fold
  515.     if $me->{'mail_hdr_modify'};
  516.  
  517.  # Build a hash
  518.  my $hash={ map { $_ => [ $me->get($_) ] } keys %{$me->{'mail_hdr_hash'}} }; 
  519.  
  520.  return $hash;
  521. }
  522.  
  523. sub add
  524. {
  525.  my $me = shift;
  526.  my($tag,$text,$where) = @_;
  527.  my $line;
  528.  ($tag,$line) = _fmt_line($me,$tag,$text);
  529.  
  530.  # Must have a tag and text to add
  531.  return undef
  532.     unless(defined $tag && defined $line);
  533.  
  534.  $where = -1
  535.     unless defined $where;
  536.  
  537.  _insert($me,$tag,$line,$where);
  538.  
  539.  $line =~ /^\S+\s(.*)/os;
  540.  return $1;
  541. }
  542.  
  543. sub replace
  544. {
  545.  my $me = shift;
  546.  my $idx = 0;
  547.  my($tag,$line);
  548.  
  549.  $idx = pop @_
  550.     if(@_ % 2);
  551.  
  552. TAG:
  553.  while(@_)
  554.   {
  555.    ($tag,$line) = _fmt_line($me,splice(@_,0,2));
  556.  
  557.    return undef
  558.         unless(defined $tag && defined $line);
  559.  
  560.    if(exists $me->{'mail_hdr_hash'}{$tag} &&
  561.       defined $me->{'mail_hdr_hash'}{$tag}[$idx])
  562.     {
  563.      ${$me->{'mail_hdr_hash'}{$tag}[$idx]} = $line;
  564.     }
  565.    else
  566.     {
  567.      _insert($me,$tag,$line,-1);
  568.     }
  569.   }
  570.  
  571.  $line =~ /^\S+\s*(.*)/os;
  572.  return $1;
  573. }
  574.  
  575. sub combine
  576. {
  577.  my $me  = shift;
  578.  my $tag = _tag_case(shift);
  579.  my $with = shift || ' ';
  580.  my $line;
  581.  
  582.  return _error "unadorned 'From ' ignored"
  583.     if($tag =~ /^From /io && $me->{'mail_hdr_mail_from'} ne 'KEEP');
  584.  
  585.  return undef
  586.     unless exists $me->{'mail_hdr_hash'}{$tag};
  587.  
  588.  if(scalar(@{$me->{'mail_hdr_hash'}{$tag}}) > 1)
  589.   {
  590.    my @lines = $me->get($tag);
  591.  
  592.    chomp(@lines);
  593.  
  594.    map { $$_ = undef } @{$me->{'mail_hdr_hash'}{$tag}};
  595.  
  596.    $line = ${$me->{'mail_hdr_hash'}{$tag}[0]} = 
  597.         (_fmt_line($me,$tag, join($with,@lines),1))[1];
  598.  
  599.    _tidy_header($me);
  600.   }
  601.  else
  602.   {
  603.    return $me->{'mail_hdr_hash'}{$tag}[0];
  604.   }
  605.  
  606.  return $line;        # post-match
  607. }
  608.  
  609. sub get
  610. {
  611.  my $me = shift;
  612.  my $tag = _tag_case(shift);
  613.  my $idx = shift;
  614.  
  615.  return wantarray ? () : undef
  616.     unless exists $me->{'mail_hdr_hash'}{$tag};
  617.  
  618.  my $l = length($tag);
  619.  $l += 1 unless $tag =~ / \Z/o;
  620.  
  621.  $idx = 0
  622.     unless defined $idx || wantarray;
  623.  
  624.  if(defined $idx)
  625.   { 
  626.    return defined $me->{'mail_hdr_hash'}{$tag}[$idx]
  627.         ?  eval { # why won't do work here ??
  628.            my $tmp = substr(${$me->{'mail_hdr_hash'}{$tag}[$idx]}, $l);
  629.           $tmp =~ s/^\s+//;
  630.           $tmp;
  631.       }
  632.         : undef;
  633.   }
  634.  
  635.  return  map {
  636.         my $tmp = substr($$_,$l);
  637.         $tmp =~ s/^\s+//;
  638.         $tmp
  639.          } @{$me->{'mail_hdr_hash'}{$tag}};
  640. }
  641.  
  642. sub count
  643. {
  644.  my $me = shift;
  645.  my $tag = _tag_case(shift);
  646.  
  647.  exists $me->{'mail_hdr_hash'}{$tag}
  648.     ? scalar(@{$me->{'mail_hdr_hash'}{$tag}})
  649.     : 0;
  650. }
  651.  
  652. sub exists
  653. {
  654.  carp "Depriciated use of Mail::Header::exists, use count" if $^W;
  655.  count(@_);
  656. }
  657.  
  658. sub delete
  659. {
  660.  my $me  = shift;
  661.  my $tag = _tag_case(shift);
  662.  my $idx = shift;
  663.  my @val = ();
  664.  
  665.  if(defined $me->{'mail_hdr_hash'}{$tag})
  666.   {
  667.    my $l = length($tag);
  668.    $l += 2 unless $tag =~ / \Z/o;
  669.  
  670.    if(defined $idx)
  671.     {
  672.      if(defined $me->{'mail_hdr_hash'}{$tag}[$idx])
  673.       {
  674.        push(@val, substr(${$me->{'mail_hdr_hash'}{$tag}[$idx]},$l));
  675.        undef ${$me->{'mail_hdr_hash'}{$tag}[$idx]};
  676.       }
  677.     }
  678.    else
  679.     {
  680.      local $_;
  681.      @val = map {
  682.                  my $x = substr($$_,$l);
  683.                  undef $$_;
  684.                  $x
  685.                 } @{$me->{'mail_hdr_hash'}{$tag}};
  686.     }
  687.  
  688.    _tidy_header($me);
  689.   }
  690.  
  691.  return @val;
  692. }
  693.  
  694. sub print
  695. {
  696.  my $me = shift;
  697.  my $fd = shift || \*STDOUT;
  698.  my $ln;
  699.  
  700.  foreach $ln (@{$me->{'mail_hdr_list'}})
  701.   {
  702.    next
  703.     unless defined $ln;
  704.    print $fd $ln or
  705.     return 0;
  706.   }
  707.  
  708.  1;
  709. }
  710.  
  711. sub as_string
  712. {
  713.  my $me = shift;
  714.  
  715.  join('', grep { defined } @{$me->{'mail_hdr_list'}});
  716. }
  717.  
  718. sub fold_length
  719. {
  720.  my $me  = shift;
  721.  my $old;
  722.  
  723.  if(@_ == 2)
  724.   {
  725.    my($tag,$len) = @_;
  726.  
  727.    my $hash = ref($me) ? $me->{'mail_hdr_lengths'} : \%HDR_LENGTHS;
  728.  
  729.    $tag = _tag_case($tag);
  730.  
  731.    $old = $hash->{$tag} || undef;
  732.    $hash->{$tag} = $len > 20 ? $len : 20;
  733.   }
  734.  else
  735.   {
  736.    my $len = shift;
  737.  
  738.    $old = $me->{'mail_hdr_foldlen'};
  739.  
  740.    if(defined $len)
  741.     {
  742.      $me->{'mail_hdr_foldlen'} = $len > 20 ? $len : 20;
  743.      $me->fold if $me->{'mail_hdr_modify'};
  744.     }
  745.   }
  746.  
  747.  $old;
  748. }
  749.  
  750. sub tags
  751. {
  752.  my $me = shift;
  753.  
  754.  keys %{$me->{'mail_hdr_hash'}};
  755. }
  756.  
  757. sub dup
  758. {
  759.  my $me = shift;
  760.  my $type = ref($me) || croak "Cannot dup without an object";
  761.  my $dup = new $type;
  762.  
  763.  %$dup = %$me;
  764.  $dup->empty;
  765.  
  766.  $dup->{'mail_hdr_list'} = [ @{$me->{'mail_hdr_list'}} ];
  767.  
  768.  my $ln;
  769.  foreach $ln ( @{$dup->{'mail_hdr_list'}} )
  770.   {
  771.    my $tag = _tag_case(($ln =~ /\A($FIELD_NAME|From )/oi)[0]);
  772.  
  773.    $dup->{'mail_hdr_hash'}{$tag} ||= [];
  774.    push(@{$dup->{'mail_hdr_hash'}{$tag}}, \$ln);
  775.   }
  776.  
  777.  $dup;
  778. }
  779.  
  780. sub cleanup
  781. {
  782.  my $me = shift;
  783.  my $d = 0;
  784.  my $key;
  785.  
  786.  foreach $key (@_ ? @_ : keys %{$me->{'mail_hdr_hash'}})
  787.   {
  788.    my $arr = $me->{'mail_hdr_hash'}{$key};
  789.    my $ref;
  790.    foreach $ref (@$arr)
  791.     {
  792.      unless($$ref =~ /\A\S+\s+\S/soi)
  793.       {
  794.        $$ref = undef;
  795.        $d++;
  796.       }
  797.     }
  798.   }
  799.  
  800.  _tidy_header($me)
  801.     if $d;
  802.  
  803.  $me;  
  804. }
  805.  
  806. 1; # keep require happy
  807.  
  808.  
  809. =head1 NAME
  810.  
  811. Mail::Header - manipulate mail RFC822 compliant headers
  812.  
  813. =head1 SYNOPSIS
  814.  
  815.     use Mail::Header;
  816.     
  817.     $head = new Mail::Header;
  818.     $head = new Mail::Header \*STDIN;
  819.     $head = new Mail::Header [<>], Modify => 0;
  820.  
  821. =head1 DESCRIPTION
  822.  
  823. This package provides a class object which can be used for reading, creating,
  824. manipulating and writing RFC822 compliant headers.
  825.  
  826. =head1 CONSTRUCTOR
  827.  
  828. =over 4
  829.  
  830. =item new ( [ ARG ], [ OPTIONS ] )
  831.  
  832. C<ARG> may be either a file descriptor (reference to a GLOB)
  833. or a reference to an array. If given the new object will be
  834. initialized with headers either from the array of read from 
  835. the file descriptor.
  836.  
  837. C<OPTIONS> is a list of options given in the form of key-value
  838. pairs, just like a hash table. Valid options are
  839.  
  840. =over 8
  841.  
  842. =item B<Modify>
  843.  
  844. If this value is I<true> then the headers will be re-formatted,
  845. otherwise the format of the header lines will remain unchanged.
  846.  
  847. =item B<MailFrom>
  848.  
  849. This option specifies what to do when a header in the form `From '
  850. is encountered. Valid values are C<IGNORE> - ignore and discard the header,
  851. C<ERROR> - invoke an error (call die), C<COERCE> - rename them as Mail-From
  852. and C<KEEP> - keep them.
  853.  
  854. =item B<FoldLength>
  855.  
  856. The default length of line to be used when folding header lines
  857.  
  858. =back
  859.  
  860. =back
  861.  
  862. =head1 METHODS
  863.  
  864. =over 4
  865.  
  866. =item modify ( [ VALUE ] )
  867.  
  868. If C<VALUE> is I<false> then C<Mail::Header> will not do any automatic
  869. reformatting of the headers, other than to ensure that the line
  870. starts with the tags given.
  871.  
  872. =item mail_from ( OPTION )
  873.  
  874. C<OPTION> specifies what to do when a C<`From '> line is encountered.
  875. Valid values are C<IGNORE> - ignore and discard the header,
  876. C<ERROR> - invoke an error (call die), C<COERCE> - rename them as Mail-From
  877. and C<KEEP> - keep them.
  878.  
  879. =item fold ( [ LENGTH ] )
  880.  
  881. Fold the header. If C<LENGTH> is not given then C<Mail::Header> uses the
  882. following rules to determine what length to fold a line.
  883.  
  884. The fold length for the tag that is begin processed
  885.  
  886. The default fold length for the tag that is being processed
  887.  
  888. The default fold length for the object
  889.  
  890. =item extract ( ARRAY_REF )
  891.  
  892. Extract a header from the given array. C<extract> B<will modify> this array.
  893. Returns the object that the method was called on.
  894.  
  895. =item read ( FD )
  896.  
  897. Read a header from the given file descriptor.
  898.  
  899. =item empty ()
  900.  
  901. Empty the C<Mail::Header> object of all lines.
  902.  
  903. =item header ( [ ARRAY_REF ] )
  904.  
  905. C<header> does multiple operations. First it will extract a header from
  906. the array, if given. It will the reformat the header, if reformatting
  907. is permitted, and finally return a reference to an array which
  908. contains the header in a printable form.
  909.  
  910. =item header_hashref ( [ HASH_REF ] )
  911.  
  912. As C<header>, but it will eventually set headers from a hash
  913. reference, and it will return the headers as a hash reference.
  914.  
  915. The values in the hash might either be a scalar or an array reference,
  916. as an example:
  917.  
  918.     $hashref->{From}='Tobias Brox <tobix@cpan.org>';
  919.     $hashref->{To}=['you@somewhere', 'me@localhost'];
  920.  
  921. =item add ( TAG, LINE [, INDEX ] )
  922.  
  923. Add a new line to the header. If C<TAG> is I<undef> the the tag will be
  924. extracted from the beginning of the given line. If C<INDEX> is given
  925. the new line will be inserted into the header at the given point, otherwise
  926. the new line will be appended to the end of the header.
  927.  
  928. =item replace ( TAG, LINE [, INDEX ] )
  929.  
  930. Replace a line in the header.  If C<TAG> is I<undef> the the tag will be
  931. extracted from the beginning of the given line. If C<INDEX> is given
  932. the new line will replace the Nth instance of that tag, otherwise the
  933. first instance of the tag is replaced. If the tag does not appear in the
  934. header then a new line will be appended to the header.
  935.  
  936. =item combine ( TAG [, WITH ] )
  937.  
  938. Combine all instances of C<TAG> into one. The lines will be
  939. joined togther with C<WITH>, or a single space if not given. The new
  940. item will be positioned in the header where the first instance was, all
  941. other instances of <TAG> will be removed.
  942.  
  943. =item get ( TAG [, INDEX ] )
  944.  
  945. Get the text form a line. If C<INDEX> is given then the text of the Nth
  946. instance will be returned. If it is not given the return value depends on the
  947. context in which C<get> was called. In an array context a list of all the
  948. text from all the instances of C<TAG> will be returned. In a scalar context
  949. the text for the first instance will be returned.
  950.  
  951. =item delete ( TAG [, INDEX ] )
  952.  
  953. Delete a tag from the header. If C<INDEX> id given then the Nth instance
  954. of the tag will be removed. If C<INDEX> is not given all instances
  955. of tag will be removed.
  956.  
  957. =item count ( TAG )
  958.  
  959. Returns the number of times the given atg appears in the header
  960.  
  961. =item print ( [ FD ] )
  962.  
  963. Print the header to the given file descriptor, or C<STDOUT> if no
  964. file descriptor is given.
  965.  
  966. =item as_string ()
  967.  
  968. Returns the header as a single string.
  969.  
  970. =item fold_length ( [ TAG ], [ LENGTH ] )
  971.  
  972. Set the default fold length for all tags or just one. With no arguments
  973. the default fold length is returned. With two arguments it sets the fold
  974. length for the given tag and returns the previous value. If only C<LENGTH>
  975. is given it sets the default fold length for the current object.
  976.  
  977. In the two argument form C<fold_length> may be called as a static method,
  978. setting default fold lengths for tags that will be used by B<all>
  979. C<Mail::Header> objects. See the C<fold> method for
  980. a description on how C<Mail::Header> uses these values.
  981.  
  982. =item tags ()
  983.  
  984. Retruns an array of all the tags that exist in the header. Each tag will
  985. only appear in the list once. The order of the tags is not specified.
  986.  
  987. =item dup ()
  988.  
  989. Create a duplicate of the current object.
  990.  
  991. =item cleanup ()
  992.  
  993. Remove any header line that, other than the tag, only contains whitespace
  994.  
  995. =item unfold ( [ TAG ] )
  996.  
  997. Unfold all instances of the given tag so that they do not spread across
  998. multiple lines. IF C<TAG> is not given then all lines are unfolded.
  999.  
  1000. =back
  1001.  
  1002. =head1 AUTHOR
  1003.  
  1004. Graham Barr.  Maintained by Mark Overmeer <mailtools@overmeer.net>
  1005.  
  1006. =head1 COPYRIGHT
  1007.  
  1008. Copyright (c) 2002-2003 Mark Overmeer, 1995-2001 Graham Barr. All rights
  1009. reserved. This program is free software; you can redistribute it and/or
  1010. modify it under the same terms as Perl itself.
  1011.  
  1012. =cut
  1013.