r4295 - in
/packages/libemail-simple-perl/branches/upstream/current: Changes
META.yml lib/Email/Simple.pm t/basic.t t/header-prepend.t t/unit.t
gregoa-guest at users.alioth.debian.org
gregoa-guest at users.alioth.debian.org
Sun Nov 19 20:04:51 CET 2006
Author: gregoa-guest
Date: Sun Nov 19 20:04:51 2006
New Revision: 4295
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=4295
Log:
Load /tmp/tmp.uQkoIm2117/libemail-simple-perl-1.995 into
packages/libemail-simple-perl/branches/upstream/current.
Modified:
packages/libemail-simple-perl/branches/upstream/current/Changes
packages/libemail-simple-perl/branches/upstream/current/META.yml
packages/libemail-simple-perl/branches/upstream/current/lib/Email/Simple.pm
packages/libemail-simple-perl/branches/upstream/current/t/basic.t
packages/libemail-simple-perl/branches/upstream/current/t/header-prepend.t
packages/libemail-simple-perl/branches/upstream/current/t/unit.t
Modified: packages/libemail-simple-perl/branches/upstream/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libemail-simple-perl/branches/upstream/current/Changes?rev=4295&op=diff
==============================================================================
--- packages/libemail-simple-perl/branches/upstream/current/Changes (original)
+++ packages/libemail-simple-perl/branches/upstream/current/Changes Sun Nov 19 20:04:51 2006
@@ -1,4 +1,7 @@
Revision history for Perl extension Email::Simple.
+
+1.995 2006-10-19
+ - tentative refactoring of headers
1.992 2006-10-05
Modified: packages/libemail-simple-perl/branches/upstream/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libemail-simple-perl/branches/upstream/current/META.yml?rev=4295&op=diff
==============================================================================
--- packages/libemail-simple-perl/branches/upstream/current/META.yml (original)
+++ packages/libemail-simple-perl/branches/upstream/current/META.yml Sun Nov 19 20:04:51 2006
@@ -1,7 +1,7 @@
# http://module-build.sourceforge.net/META-spec.html
#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
name: Email-Simple
-version: 1.992
+version: 1.995
version_from: lib/Email/Simple.pm
installdirs: site
requires:
Modified: packages/libemail-simple-perl/branches/upstream/current/lib/Email/Simple.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libemail-simple-perl/branches/upstream/current/lib/Email/Simple.pm?rev=4295&op=diff
==============================================================================
--- packages/libemail-simple-perl/branches/upstream/current/lib/Email/Simple.pm (original)
+++ packages/libemail-simple-perl/branches/upstream/current/lib/Email/Simple.pm Sun Nov 19 20:04:51 2006
@@ -2,14 +2,12 @@
use 5.00503;
use strict;
-use Carp;
-
-use vars qw($VERSION $GROUCHY);
-$VERSION = '1.992';
-
-my $crlf = qr/\x0a\x0d|\x0d\x0a|\x0a|\x0d/; # We are liberal in what we accept.
-
-$GROUCHY = 0;
+use Carp ();
+
+$Email::Simple::VERSION = '1.995';
+$Email::Simple::GROUCHY = 0;
+
+my $crlf = qr/\x0a\x0d|\x0d\x0a|\x0a|\x0d/; # We are liberal in what we accept.
=head1 NAME
@@ -51,65 +49,91 @@
=cut
sub new {
- my ($class, $text) = @_;
-
- croak 'Unable to parse undefined message' if !defined $text;
-
- my ($head, $body, $mycrlf) = _split_head_from_body($text);
- my ($head_hash, $order) = _read_headers($head);
- bless {
- head => $head_hash,
- body => $body,
- order => $order,
- mycrlf => $mycrlf,
- header_names => { map { lc $_ => $_ } keys %$head_hash }
- }, $class;
+ my ($class, $text) = @_;
+
+ Carp::croak 'Unable to parse undefined message' if !defined $text;
+
+ my ($head, $body, $mycrlf) = _split_head_from_body($text);
+
+ my $self = bless { body => $body, mycrlf => $mycrlf } => $class;
+
+ $self->__read_header($head);
+
+ return $self;
}
sub _split_head_from_body {
- my $text = shift;
- # The body is simply a sequence of characters that
- # follows the header and is separated from the header by an empty
- # line (i.e., a line with nothing preceding the CRLF).
- # - RFC 2822, section 2.1
- if ($text =~ /(.*?($crlf))\2(.*)/sm) {
- return ($1, ($3 || ''), $2);
- } else { # The body is, of course, optional.
- return ($text, "", "\n");
+ my $text = shift;
+
+ # The body is simply a sequence of characters that
+ # follows the header and is separated from the header by an empty
+ # line (i.e., a line with nothing preceding the CRLF).
+ # - RFC 2822, section 2.1
+ if ($text =~ /(.*?($crlf))\2(.*)/sm) {
+ return ($1, ($3 || ''), $2);
+ } else { # The body is, of course, optional.
+ return ($text, "", "\n");
+ }
+}
+
+# Header fields are lines composed of a field name, followed by a colon (":"),
+# followed by a field body, and terminated by CRLF. A field name MUST be
+# composed of printable US-ASCII characters (i.e., characters that have values
+# between 33 and 126, inclusive), except colon. A field body may be composed
+# of any US-ASCII characters, except for CR and LF.
+
+# However, a field body may contain CRLF when used in header "folding" and
+# "unfolding" as described in section 2.2.3.
+
+sub __headers_to_list {
+ my ($self, $head) = @_;
+
+ my @headers;
+
+ for (split /$crlf/, $head) {
+ if (s/^\s+// or not /^([^:]+):\s*(.*)/) {
+ # This is a continuation line. We fold it onto the end of
+ # the previous header.
+ next if !@headers; # Well, that sucks. We're continuing nothing?
+
+ $headers[-1][1] .= $headers[-1][1] ? " $_" : $_;
+ } else {
+ push @headers, [ $1, $2 ];
}
-}
-
-# Header fields are lines composed of a field name, followed by a colon
-# (":"), followed by a field body, and terminated by CRLF. A field
-# name MUST be composed of printable US-ASCII characters (i.e.,
-# characters that have values between 33 and 126, inclusive), except
-# colon. A field body may be composed of any US-ASCII characters,
-# except for CR and LF.
-
-# However, a field body may contain CRLF when
-# used in header "folding" and "unfolding" as described in section
-# 2.2.3.
+ }
+
+ return \@headers;
+}
sub _read_headers {
- my $head = shift;
- my @head_order;
- my ($curhead, $head_hash) = ("", {});
- for (split /$crlf/, $head) {
- if (s/^\s+// or not /^([^:]+):\s*(.*)/) {
- next if !$curhead; # Well, that sucks.
- # This is a continuation line. We fold it onto the end of
- # the previous header.
- chomp $head_hash->{$curhead}->[-1];
- $head_hash->{$curhead}->[-1] .= $head_hash->{$curhead}->[-1]
- ? " $_"
- : $_;
- } else {
- $curhead = $1;
- push @{$head_hash->{$curhead}}, $2;
- push @head_order, $curhead;
- }
- }
- return ($head_hash, \@head_order);
+ Carp::carp "Email::Simple::_read_headers is private and depricated";
+ my ($head) = @_; # ARG! Why is this a function? -- rjbs
+ my $dummy = bless {} => __PACKAGE__;
+ $dummy->__read_header($head);
+ my $h = $dummy->__head->{head};
+ my $o = $dummy->__head->{order};
+ return ($h, $o);
+}
+
+sub __read_header {
+ my ($self, $head) = @_;
+
+ my $headers = $self->__headers_to_list($head);
+
+ $self->{_head}
+ = Email::Simple::__Header->new($headers, { crlf => $self->{mycrlf} });
+}
+
+sub __head {
+ my ($self) = @_;
+ return $self->{_head} if $self->{_head};
+
+ if ($self->{head} and $self->{order} and $self->{header_names}) {
+ Carp::carp "Email::Simple subclass appears to have broken header behavior";
+ my $head = bless {} => 'Email::Simple::__Header';
+ $head->{$_} = $self->{$_} for qw(head order header_names mycrlf);
+ return $self->{_head} = $head;
+ }
}
=head2 header
@@ -122,15 +146,7 @@
=cut
-sub header {
- my ($self, $field) = @_;
- return unless
- (exists $self->{header_names}->{lc $field})
- and $field = $self->{header_names}->{lc $field};
-
- return wantarray ? @{$self->{head}->{$field}}
- : $self->{head}->{$field}->[0];
-}
+sub header { $_[0]->__head->header($_[1]); }
=head2 header_set
@@ -141,36 +157,7 @@
=cut
-sub header_set {
- my ($self, $field, @data) = @_;
- if ($GROUCHY) {
- croak "field name contains illegal characters"
- unless $field =~ /^[\x21-\x39\x3b-\x7e]+$/;
- carp "field name is not limited to hyphens and alphanumerics"
- unless $field =~ /^[\w-]+$/;
- }
-
- if (!exists $self->{header_names}->{lc $field}) {
- $self->{header_names}->{lc $field} = $field;
- # New fields are added to the end.
- push @{$self->{order}}, $field;
- } else {
- $field = $self->{header_names}->{lc $field};
- }
-
- my @loci = grep { lc $self->{order}[$_] eq lc $field }
- 0 .. $#{$self->{order}};
-
- if (@loci > @data) {
- my $overage = @loci - @data;
- splice @{$self->{order}}, $_, 1 for reverse @loci[ -$overage, $#loci ];
- } elsif (@data > @loci) {
- push @{$self->{order}}, ($field) x (@data - @loci);
- }
-
- $self->{head}->{$field} = [ @data ];
- return wantarray ? @data : $data[0];
-}
+sub header_set { (shift)->__head->header_set(@_); }
=head2 header_names
@@ -185,29 +172,20 @@
=cut
-sub header_names {
- values %{ $_[0]->{header_names} }
-}
+sub header_names { $_[0]->__head->header_names }
BEGIN { *headers = \&header_names; }
=head2 header_pairs
my @headers = $email->header_pairs;
-=cut
-
-sub header_pairs {
- my ($self) = @_;
-
- my @headers;
- my %seen;
-
- for my $header (@{$self->{order}}) {
- push @headers, ($header, $self->{head}{$header}[ $seen{$header}++ ]);
- }
-
- return @headers;
-}
+This method returns a list of pairs describing the contents of the header.
+Every other value, starting with and including zeroth, is a header name and the
+value following it is the header value.
+
+=cut
+
+sub header_pairs { $_[0]->__head->header_pairs }
=head2 body
@@ -236,6 +214,29 @@
mail, they'll be added to the end.
=cut
+
+sub as_string {
+ my $self = shift;
+ return $self->__head->as_string . $self->{mycrlf} . $self->body;
+}
+
+package Email::Simple::__Header;
+
+sub new {
+ my ($class, $headers, $arg) = @_;
+
+ my $self = {};
+ $self->{mycrlf} = $arg->{crlf} || "\n";
+
+ for my $header (@$headers) {
+ push @{ $self->{order} }, $header->[0];
+ push @{ $self->{head}{ $header->[0] } }, $header->[1];
+ }
+
+ $self->{header_names} = { map { lc $_ => $_ } keys %{ $self->{head} } };
+
+ bless $self => $class;
+}
# RFC 2822, 3.6:
# ...for the purposes of this standard, header fields SHOULD NOT be reordered
@@ -244,54 +245,112 @@
# kept in blocks prepended to the message.
sub as_string {
- my $self = shift;
- return $self->_headers_as_string
- . $self->{mycrlf}
- . $self->body;
-}
-
-sub _headers_as_string {
- my ($self) = @_;
-
- my $header_str = '';
- my @pairs = $self->header_pairs;
-
- while (my ($name, $value) = splice @pairs, 0, 2) {
- $header_str .= $self->_header_as_string($name, $value);
+ my ($self) = @_;
+
+ my $header_str = '';
+ my @pairs = $self->header_pairs;
+
+ while (my ($name, $value) = splice @pairs, 0, 2) {
+ $header_str .= $self->_header_as_string($name, $value);
+ }
+
+ return $header_str;
+}
+
+sub _header_as_string {
+ my ($self, $field, $data) = @_;
+
+ # Ignore "empty" headers
+ return '' unless defined $data;
+
+ my $string = "$field: $data";
+
+ return (length $string > 78)
+ ? $self->_fold($string)
+ : ($string . $self->{mycrlf});
+}
+
+sub _fold {
+ my $self = shift;
+ my $line = shift;
+
+ # We know it will not contain any new lines at present
+ my $folded = "";
+ while ($line) {
+ $line =~ s/^\s+//;
+ if ($line =~ s/^(.{0,77})(\s|\z)//) {
+ $folded .= $1 . $self->{mycrlf};
+ $folded .= " " if $line;
+ } else {
+
+ # Basically nothing we can do. :(
+ $folded .= $line . $self->{mycrlf};
+ last;
}
-
- return $header_str;
-}
-
-sub _header_as_string {
- my ($self, $field, $data) = @_;
-
- # Ignore "empty" headers
- return '' unless defined $data;
-
- my $string = "$field: $data";
-
- return (length $string > 78) ? $self->_fold($string)
- : ( $string . $self->{mycrlf} );
-}
-
-sub _fold {
- my $self = shift;
- my $line = shift;
- # We know it will not contain any new lines at present
- my $folded = "";
- while ($line) {
- $line =~ s/^\s+//;
- if ($line =~ s/^(.{0,77})(\s|\z)//) {
- $folded .= $1.$self->{mycrlf};
- $folded .= " " if $line;
- } else {
- # Basically nothing we can do. :(
- $folded .= $line . $self->{mycrlf};
- last;
- }
- }
- return $folded;
+ }
+ return $folded;
+}
+
+sub header_names {
+ values %{ $_[0]->{header_names} };
+}
+
+sub header_pairs {
+ my ($self) = @_;
+
+ my @headers;
+ my %seen;
+
+ for my $header (@{ $self->{order} }) {
+ push @headers, ($header, $self->{head}{$header}[ $seen{$header}++ ]);
+ }
+
+ return @headers;
+}
+
+sub header {
+ my ($self, $field) = @_;
+ return
+ unless (exists $self->{header_names}->{ lc $field })
+ and $field = $self->{header_names}->{ lc $field };
+
+ return wantarray
+ ? @{ $self->{head}->{$field} }
+ : $self->{head}->{$field}->[0];
+}
+
+sub header_set {
+ my ($self, $field, @data) = @_;
+
+ # I hate this block. -- rjbs, 2006-10-06
+ if ($Email::Simple::GROUCHY) {
+ Carp::croak "field name contains illegal characters"
+ unless $field =~ /^[\x21-\x39\x3b-\x7e]+$/;
+ Carp::carp "field name is not limited to hyphens and alphanumerics"
+ unless $field =~ /^[\w-]+$/;
+ }
+
+ if (!exists $self->{header_names}->{ lc $field }) {
+ $self->{header_names}->{ lc $field } = $field;
+
+ # New fields are added to the end.
+ push @{ $self->{order} }, $field;
+ } else {
+ $field = $self->{header_names}->{ lc $field };
+ }
+
+ my @loci =
+ grep { lc $self->{order}[$_] eq lc $field } 0 .. $#{ $self->{order} };
+
+ if (@loci > @data) {
+ my $overage = @loci - @data;
+ splice @{ $self->{order} }, $_, 1 for reverse @loci[ -$overage, $#loci ];
+ } elsif (@data > @loci) {
+ push @{ $self->{order} }, ($field) x (@data - @loci);
+ }
+
+ $self->{head}->{$field} = [@data];
+ return wantarray ? @data : $data[0];
}
1;
Modified: packages/libemail-simple-perl/branches/upstream/current/t/basic.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libemail-simple-perl/branches/upstream/current/t/basic.t?rev=4295&op=diff
==============================================================================
--- packages/libemail-simple-perl/branches/upstream/current/t/basic.t (original)
+++ packages/libemail-simple-perl/branches/upstream/current/t/basic.t Sun Nov 19 20:04:51 2006
@@ -1,6 +1,6 @@
#!/usr/bin/perl -w
use strict;
-use Test::More tests => 18;
+use Test::More tests => 17;
sub read_file { local $/; local *FH; open FH, shift or die $!; return <FH> }
use_ok("Email::Simple");
@@ -8,8 +8,6 @@
my $mail_text = read_file("t/test-mails/josey-nofold");
my $mail = Email::Simple->new($mail_text);
isa_ok($mail, "Email::Simple");
-
-like($mail->{head}->{From}->[0], qr/Andrew/, "Andrew's in the header");
my $old_from;
is($old_from = $mail->header("From"),
Modified: packages/libemail-simple-perl/branches/upstream/current/t/header-prepend.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libemail-simple-perl/branches/upstream/current/t/header-prepend.t?rev=4295&op=diff
==============================================================================
--- packages/libemail-simple-perl/branches/upstream/current/t/header-prepend.t (original)
+++ packages/libemail-simple-perl/branches/upstream/current/t/header-prepend.t Sun Nov 19 20:04:51 2006
@@ -22,8 +22,8 @@
sub Email::Simple::header_prepend {
my ($self, $field, @values) = @_;
- unshift @{ $self->{order} }, ($field) x @values;
- unshift @{ $self->{head}->{$field} }, @values;
+ unshift @{ $self->{_head}{order} }, ($field) x @values;
+ unshift @{ $self->{_head}{head}->{$field} }, @values;
}
$email->header_prepend(Alpha => 'this header comes firstest');
Modified: packages/libemail-simple-perl/branches/upstream/current/t/unit.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libemail-simple-perl/branches/upstream/current/t/unit.t?rev=4295&op=diff
==============================================================================
--- packages/libemail-simple-perl/branches/upstream/current/t/unit.t (original)
+++ packages/libemail-simple-perl/branches/upstream/current/t/unit.t Sun Nov 19 20:04:51 2006
@@ -5,7 +5,7 @@
use Email::Simple;
package Email::Simple;
-use Test::More tests => 15;
+use Test::More tests => 8;
# Simple "email", no body
@@ -34,20 +34,3 @@
is($h, "a\n", "Simple mail, head OK");
is($b, "\nb\nc\n", "Simple mail, body OK");
-# Testing the header parsing code
-
-my $head = "From: foo\n";
-my ($hh, $ord) = _read_headers($head);
-is($hh->{From}->[0], "foo", "Simplest header works");
-is_deeply($ord, ["From"], "Order is correct" );
-
-$head = "From: foo\nBar: baz\n";
-($hh, $ord) = _read_headers($head);
-is($hh->{From}->[0], "foo", "Header 2.1");
-is($hh->{Bar}->[0], "baz", "Header 2.2");
-is_deeply($ord, ["From", "Bar"], "Order is correct" );
-# Folding!
-$head = "From: foo\n baz\n";
-($hh, $ord) = _read_headers($head);
-is($hh->{From}->[0], "foo baz", "Header 3.1");
-is_deeply($ord, ["From"], "Order is correct" );
More information about the Pkg-perl-cvs-commits
mailing list