File Coverage

blib/lib/Text/Header.pm

Criterion	Covered	Total	%
statement	9	31	29.0
branch	0	2	0.0
condition	0	3	0.0
subroutine	3	5	60.0
pod	0	2	0.0
total	12	43	27.9

# $Id: Header.pm,v 1.3 2000/10/02 17:43:20 nwiger Exp $
####################################################################
#
# Copyright (c) 2000 Nathan Wiger
#
# This simple module provides two functions, header and unheader,
# which do lightweight, general-purpose RFC 822 header parsing.
#
# This module is intended mainly as a proof-of-concept for the Perl
# 6 proposal located at: http://dev.perl.org/rfc/3__.html
#
####################################################################
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
# 02111-1307, USA.
#
####################################################################

package Text::Header;
require 5.004;

use strict;
use vars qw(@EXPORT @ISA $VERSION);
$VERSION = do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf "%d."."%02d"x$#r,@r };

use Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(header unheader);

sub header {
    my @ret;
    my @args = @_;

    # go through each tag pair, reformatting the tag
    # and pushing it onto an array
    while (my $tag = shift @args and my $val = shift @args) {
        chomp($tag = ucfirst lc $tag);
        $tag =~ s/[-_](\w)/-\u$1/g;
        if ( ref $val ) {
           $val = join ', ', @$val;
        }
        chomp $val;
        push @ret, "$tag: $val\n";
    }
    return @ret;
}

sub unheader {
    my @ret;
    chomp(my @lines = @_);
    my $i = 0;
    while (my $line = $lines[$i]) {

        # join multiple indented lines per RFC 822
        $line .= $lines[$i] while ($lines[++$i] =~ /^\s+/);

        # split the two and change the tag to lowercase
        my($tag, $val) = $line =~ m/([-\w]+)\s*:\s*(.*)/s;
        $tag = lc $tag;
        $tag =~ s/-/_/g;

        # some cleanup
        $val =~ s/\n\s*/ /g;
        $val =~ s/\s*,\s+/, /g;
        push @ret, $tag, $val;
    }
    return @ret;
}

1;

__END__