# The "official source" for this file is in the source code to my FAQ server.
#   - jik 2/26/93

package header;

# Takes two arguments, a starting line (with its newline) and a
# file handle to read further strings from.  The starting string
# should be undef if there is none.
# 
# Returns the first line of the next section, if any, with its
# newline, and an associative array of header field names and values.

sub parse {
    local(%headers) = ();
    local($current, $fhandle) = @_;
    local($done) = 0;
    local($_);
    local($package) = caller;

    if ($fhandle !~ /\'/) {
	$fhandle = "$package'$fhandle";
    }

    $text_read = "";

    if ($current && ! ($current =~ /^[^ \t]+:/)) {
	# We're not at the start of a header
	return($current, %headers);
    }

    $text_read .= $current;

    while (($_ = <$fhandle>) || $current) {
	if ($_ && /^[ \t]+/) {
	    # A line starting with whitespace indicates a continuation
	    # line
	    $current .= $_;
	}
	else {
	    if ($current) {
		local(@fields) = split(/:[ \t]*/, $current, 2);
		$fields[0] =~ tr/A-Z/a-z/;
		if ($headers{$fields[0]}) {
		    $headers{$fields[0]} .= $current;
		}
		else {
		    $headers{$fields[0]} = $current;
		}
	    }
	    if (/^$/) {
		$done++;
		while (/^$/) {
		    $text_read .= $_;
		    last if (! ($_ = <$fhandle>));
		}
	    }
	    $current = $_;
	    return($current, %headers) 
		if ($done || !($current && /^[^ \t]+:/));
	}
	$text_read .= $_;
    }
}
    
sub print {
    local($fhandle, %headers) = @_;
    local($key);

    foreach $key (keys(%headers)) {
	print $fhandle "$headers{$key}";
    }
}

sub field_exists {
    local($field, %headers) = @_;

    $field =~ tr/A-Z/a-z/;
    $headers{$field};
}

sub field_value {
    local($field, %headers) = @_;
    local($*) = 1;

    $field =~ tr/A-Z/a-z/;
    $field = $headers{$field};

    return $field if (!$field);

    chop $field;

    if ($field =~ /\n[^ \t]/) {
	# There are multiple instances of this field in the header;
 	# that's not allowed when using field_value
	return undef;
    }

    $field =~ s/^[^ \t]+:[ \t]*//;
    $field =~ s/\s+$//;
    return($field);
}

sub set_field {
    local($field, $value, *headers) = @_;
    local($newfield) = $field;

    $newfield =~ tr/A-Z/a-z/;

    $headers{$newfield} = "$field: $value\n";
}

sub delete_field {
    local($field, *headers) = @_;

    $field =~ tr/A-Z/a-z/;
    delete $headers{$field};
}

sub is_multiple {
    local($field, %headers) = @_;

    $field =~ tr/A-Z/a-z/;
    $field = $headers{$field};

    $field && ($field =~ /\n[^ \t]/);
}

1;