#!/arch/unix/bin/perl
#
# Mail header ADT
#  headers_init(@headers)            Inits data structures for the headers.
#  headers_dump()                    Prints current headers in RFC-822 mode.
#  header_get("header")              Returns the value of the header, string.
#  header_get_all("header")          Returns the value of the header, array.
#  header_set("header", "value")     Sets the value of the header.
#  header_add("header", "value")     Appends to the value of the header.
#  header_remove("header")           Removes a header from the headers.
#  header_exists("header")           True if the header exists.
#  header_matches("header", "value") True if the header matches the regexp.
#  header_ucbfrom()                  Returns the From line if it was there.
#
#  To: remy, bdowling,
#        django
#  Subject: foo
#  X-Request-Do: resolve
#  X-Request-Do: give ray
#
#  header_get("to")           -> "remy, bdowling, django"
#  header_get("subject")      -> foo
#  header_get("x-request-do") -> resolve give ray
#
#  header_set("subject", "hello")           -> Subject: hello
#  header_set("x-request-do", "prio high")  -> X-Request-Do: prio high
#    do line wrap if necessary
#
#  Internal variables:
#     @header_data
#     @header_type
#     %header_info
#
# 
package reqmail;

$reqmail_debug = $main'reqmail_debug;
1;


sub main'read_the_mail {
  #
  # Read the mail, and break it into header/body.  Assume it's coming 
  # from stdin.
  #
  local(@header, @body);
  while(<STDIN>) {
    chop;
    last if(/^\s*$/);
    push(@header, $_);
  }
  while(<STDIN>) {
    chop;
    push(@body, $_);
  }
  return(@header, @body);
}



sub main'headers_init {
  #
  # Read the header passed in as an array, and build an associative array
  # out of the headers, where the values of the assoc array for a particular
  # header are the indeces into the array for every line which is that 
  # type of header.
  # 
  # A `,' in the assoc array indicates a continuation line.
  # A `:' in the assoc array indicates an additional header.
  #
  # A header like this:
  #    From: me, you, us, them,
  #            others, friends
  #    Subject: some mail
  #    X-Request-Do: take
  #    X-Request-Do: prio high
  #
  # Will result in an assoc array:
  #    %header_info{"from"} = "0,1"
  #    %header_info{"subject"} = "2"
  #    %header_info{"x-request-do"} = "3:4"
  #
  # And arrays:
  #    header_data( "me, you, us, them,", "others, friends", "some mail", 
  #                 "take", "prio high")
  #    header_type( "From", "", "Subject", "X-Request-Do", "X-Request-Do" )
  #
  @header_lines = @_;
  local($i, $length, $tag);

  @header_data = ();
  @header_type = ();
  %header_info = ();

  $tag = "";
  $length = $#header_lines;

  for($i=0; $i<=$length; $i++) {
    $line = shift(@header_lines);
    if($line =~ /^\s+\S/) {                     # Starts with space
      $line =~ /^\s*(.*)$/;                      # Get all non-space in $1
      $header_data[$i] = $1;                     # Get the data
      $header_type[$i] = "";
      if($tag ne "") {
        if($header_info{$tag}) {                 # Update the assoc index
          $header_info{$tag} .= ",$i";
        } else {
          $header_info{$tag} = "$i";
        }
      } else {
        if($reqmail_debug) {
          print("Hmm, got a blank-starting header, ",
                "but have no previous header.\n");
        }
      }
    } elsif ($line =~ /^(\S+):/) {              # Found a header
      $header_type[$i] = $tag = $1;
      $tag =~ tr/A-Z/a-z/;                       # Downcase it
      $line =~ /^\S+:\s*(.*)$/;                  # Get everything after a :
      $header_data[$i] = $1;

      if($header_info{$tag}) {                   # Update the assoc index
        $header_info{$tag} .= ":$i";
      } else {
        $header_info{$tag} = "$i";
      }
    } elsif ($line =~ /from (\S+)/i) {
      # Found the From Person line imbedded by some sendmails and used
      # by 'from' and various other things.  Save it, but don't count it. 
      $header_ucbfrom = $1;
      $i--;
      $length--;
    } else {
      # Well, we've got a malformed header.  Hmm.  Let 'em know if 
      # they care.
      if($reqmail_debug) {
        print("header_init, reading header, line ", $i+1, ", bad header:\n");
        print("$line\n");
      }
      # Don't count this line, then.
      $i--;
      $length--;
    }
  }
}


sub main'header_ucbfrom {
  #
  # Return the ucbfrom if we found it.
  #
  $header_ucbfrom ? $header_ucbfrom : "";
}


sub main'headers_dump {
  #
  # Dump out the header info.
  #
  local($i, $rv);

  $rv = 1;
  print "Headers:\n" if ($reqmail_debug);
  for($i=0; $i<=$#header_type; $i++) {
    if($header_type[$i] eq "removed header") {
      next;
    } elsif($header_type[$i]) {
      if(!print(&capcase($header_type[$i]), ": $header_data[$i]\n")) {
        $rv = 0;
      }
    } else {
      if(!print("        $header_data[$i]\n")) {
        $rv = 0;
      }
    }
  }
  if ($reqmail_debug) {
    print "Header data:\n";
    foreach $k (sort(keys(%header_info))) {
      print(" $k: $header_info{$k}\n");
    }
  }
  $rv;
}


sub main'header_get {
  #
  # Get a header value as a string.  If there are multiple lines for that 
  # header, concatenate them all together separated by spaces and return 
  # them all.
  #
  # A non-existent header returns a "".
  #
  # I'm not sure yet if this is the right behavior, but it probably is.
  # 
  local($h) = @_;
  local($i, $r, @v, @index);

  $h =~ tr/A-Z/a-z/;
  $h =~ s/:$//;

  if(defined($i = $header_info{$h})) {
    @index = (split("[,:]", $i));
    for $r (@index) {
      push(@v, $header_data[$r]);
    }
    return(join(" ",@v));
  }
  return "";
}


sub main'header_get_all {
  #
  # Get a header value returned as an array, where each separate line
  # is an entry in the array.
  #
  # A non-existent header returns a ().
  #
  local($h) = @_;
  local($i, $r, @v, @index);

  $h =~ tr/A-Z/a-z/;
  $h =~ s/:$//;

  if(defined($i = $header_info{$h})) {
    @index = (split("[,:]", $i));
    for $r (@index) {
      push(@v, $header_data[$r]);
    }
    return(@v);
  }
  return ();
}


sub main'header_set {
  #
  # Set a header value.  Returns the value set.
  # At this point, we only allow one line to be set.
  # It replaces any previously existing values for that header.
  # 
  local($h, $new_value) = @_;
  local($i);

  $h =~ tr/A-Z/a-z/;
  $h =~ s/:$//;

  if(defined($i = $header_info{$h})) {
    @index = (split("[,:]", $i));
    $i = shift(@index);
    $header_data[$i] = $new_value;
    $header_info{$h} = "$i";
    for $i (@index) {
      $header_type[$i] = "removed header";
    }
  } else {
    $h = &capcase($h);
    push(@header_type, $h);
    push(@header_data, $new_value);
    $header_info{$h} = "$#header_type";
  }    
  return $new_value;
}


sub main'header_add {
  #
  # Appends a value to the header.  Returns the value set.
  #
  # Isn't smart enough to actually make a new line for the header, because 
  # that hasn't been needed yet.  Instead, it just tacks the data on the 
  # end of the last line for that header.
  #
  local($h, $new_value) = @_;
  local($i);

  $h =~ tr/A-Z/a-z/;
  $h =~ s/:$//;

  if(defined($i = $header_info{$h})) {
    @index = (split("[,:]", $i));
    $i = $index[$#index];
    if(&should_append_with_commas($h) && $new_value !~ /^,/) {
      $header_data[$i] .= ", $new_value";
    } else {
      $header_data[$i] .= "$new_value";
    }
  } else {
    $h = &capcase($h);
    push(@header_type, $h);
    push(@header_data, $new_value);
    $header_info{$h} = "$#header_type";
  }    
  return $new_value;
}  
 

sub main'header_exists {
  #
  # True if the header type exists.
  #
  local($h) = @_;

  $h =~ tr/A-Z/a-z/;
  $h =~ s/:$//;
  
  return defined($header_info{$h}) ? 1 : 0;
}


sub main'header_matches {
  #
  # True if the header exists and matches the regexp passed in.
  #
  # Note that the regexp is passed in as a string, so it will need
  # any special symbols escaped:
  #   "\\bfoo\\W"
  #
  local($h, $exp) = @_;
  local($i);

  $h =~ tr/A-Z/a-z/;
  $h =~ s/:$//;

  if(defined($header_info{$h})) {
    for $i (&main'header_get_all($h)) {
      if($i =~ /$exp/) {
        return 1;
      }
    }
  }
  return 0;
}


sub main'header_matches_i {
  #
  # True if the header exists and matches the regexp passed in,
  #  incasesensitive.
  #
  local($h, $exp) = @_;
  local($i);

  $h =~ tr/A-Z/a-z/;
  $h =~ s/:$//;

  if(defined($header_info{$h})) {
    for $i (&main'header_get_all($h)) {
      if($i =~ /$exp/i) {
        return 1;
      }
    }
  }
  return 0;
}


sub capcase {
  #
  # Turn "hello-world" into "Hello-World".
  # Oh, I wish this were a real language.
  #
  local($f) = @_;
  local(@w, $up, $c, @new);
  
  $up = 1;
  @w = split(//, $f);

  for $c (@w) {
    if($up) {
      $up = 0;
      $c =~ tr/a-z/A-Z/;
    } else {
      $c =~ tr/A-Z/a-z/;
    }
    if($c eq "-") {
      $up = 1;
    }
    push(@new, $c);
  }
  
  join("", @new);
}


sub should_append_with_commas {
  #
  # Based on the header name, see if it will need commas to be appended.
  #
  local($h) = @_;
 
  ($h eq "to" ||
   $h eq "from" ||
   $h eq "cc" ||
   $h eq "apparently-to" ||
   $h eq "reply-to");
}


