use v6-alpha;
use HTTP::Headers;
class HTTP::Message-0.1;
our $CRLF = "\o15\o12";
has HTTP::Headers $!headers handles «
header push_header init_header remove_header remove_content_headers header_field_names scan
date expires if_modified_since if_unmodified_since last_modified
content_type content_encoding content_length content_language
title user_agent server from referer
www_authenticate authorization proxy_authorization authorization_basic proxy_authorization_basic
»;
has $!content;
has $!content_ref;
has $!protocol;
has @!parts;
multi submethod BUILD (HTTP::Headers $header, Str $content = "") {
$!headers = $header;
$!content = $content;
}
multi submethod BUILD (%header, Str $content = "") {
$!headers = HTTP::Headers.new(|%header);
$!content = $content;
}
multi submethod BUILD () {
$!headers = HTTP::Headers.new();
$!content = "";
}
method parse (Str $string) returns HTTP::Headers {
my %headers;
my ($field, $value);
loop {
# XXX use Perl 6 pattern matching and named binding
#if ($string ~~ s:/^ $field := (<-[ \t:]>+) <[ \t]>*\: <sp>? $value := (.*) \n?//) {
if ($string ~~ s:P5/^([^ \t:]+)[ \t]*: ?(.*)\n?//) {
$field = $0;
$value = $1;
#$value ~~ s/\r$//;
$value ~~ s:P5/\r\z//;
%headers{$field} = $value;
} elsif (%headers.pairs && $string ~~ s/^ (<[ \t]> .*) \n?//) {
%headers{$field} ~= "\n$0";
#%headers{$field} ~~ s/\r$//;
%headers{$field} ~~ s:P5/\r\z//;
} else {
$string ~~ s:P5/^\r?\n//;
last;
}
}
return ::?CLASS.new(%headers, $string);
}
method clear ($self: ) returns Void {
$!headers.clear();
$self.content = '';
@!parts = ();
return;
}
method protocol (Str $protocol?) is rw {
return Proxy.new(
FETCH => { $!protocol; },
STORE => -> Str $val { $!protocol = $val; }
);
}
# XXX this might need to be rewritten
method content ($self: Str $content?, Bool $keep?) is rw {
return Proxy.new(
FETCH => {
if (want.List) {
$!content unless $!content.defined;
my $old = $!content;
$old = $$old if $old.WHAT eq "Scalar";
return $old;
}
},
STORE => -> Str $content, Bool $keep? {
if (want ~~ List) {
$!content unless $!content.defined;
my $old = $self!content;
$old = $$old if $old.WHAT eq "Scalar";
}
$!content = $content;
#@!parts = () if $del;
$self!set_content($content, $keep);
return $old if want.List;
});
}
my method set_content (Str $content, Bool $keep?) returns Void {
$!content = $content;
@!parts = () unless $keep;
}
# XXX does add_content() need to create references, etc. like the P5 version?
# I figure it shouldn't be needed since the parameters are bound, not copied.
method add_content (Str $content) {
$!content ~= $content;
}
method content_ref (Ref $content?) is rw {
$!content unless $!content.defined;
@!parts = ();
my $old = \$!content;
my $old_ref = $!content_ref;
$old = $$old if $old_ref;
return Proxy.new(
FETCH => { return $old; },
STORE => -> Ref $content {
$!content = $content;
$!content_ref++;
return $old;
});
}
# XXX decoded_content needs to be ported. It requires:
# HTTP::Headers::Util (done)
# Compress::Zlib
# Compress::Bzip2
# MIME::Base64
# MIME::QuotedPrint
# Encode
method decoded_content ($self: ) {
...
}
method as_string ($self: Str $newline = "\n") returns Str {
my $content = $self.content;
return [~] ($!headers.as_string($newline), $newline, ($content.chars && $content !~~ /\n$/) ?? "\n" !! "");
}
method parts ($self: *@new) is rw {
my @old = @!parts;
return Proxy.new(
FETCH => { return @old if want.List; return @old[0]; },
STORE => -> *@new {
my $content_type = $self.content_type // "";
if ($content_type ~~ m,^message/,) {
die "Only one part allowed for $content_type content!"
if @new > 1;
} elsif ($content_type !~~ m,^multipart/,) {
$self.remove_content_headers;
$self.content_type("multipart/mixed");
}
@!parts = @new;
$self!stale_content;
return @old if want.List;
return @old[0];
});
}
method add_part ($self: ::?CLASS $part) returns Void {
if ((.content_type // "") !~~ m,^multipart/,) {
my $message = ::?CLASS.new(.remove_content_headers, .content(""));
$self.content_type("multipart/mixed");
@!parts = $message;
} elsif (!@!parts) {
@!parts;
}
push @!parts, $part;
$self!stale_content;
return;
}
my method stale_content () {
undefine($!content);
undefine($!content_ref);
}
my method parts ($self: ) {
my $content_type = .content_type;
if ($content_type ~~ m,^multipart/,) {
my @h = HTTP::Headers::Util::split_header_words(.header("Content-Type"));
my %h = %(@h[0]);
if ((my $boundary = $h<boundary>).defined) {
my $str = $self.content;
if ($str ~~ s:P5/(^|.*?\r?\n)--\Q$boundary\E\r?\n//) {
@!parts = split(rx:P5/\r?\n--\Q$b\E\r?\n/, $str).map:{ HTTP::Message::parse($_); };
}
}
} elsif ($content_type eq "message/http") {
my $content = $self.content;
my $class = ($content ~~ m,^(HTTP/.*)\n,) ?? HTTP::Response !! HTTP::Request;
@!parts = $class.parse($content);
} elsif ($content_type ~~ m,message/,) {
@!parts = HTTP::Message.parse($self.content);
}
@!parts //= ();
}
my method content ($self: ) {
my $content_type = $self.content_type // "";
if ($content_type ~~ m:i,^\s*message/,) {
$self!set_content(@!parts[0].as_string($CRLF), 1);
return;
}
my @v = HTTP::Headers::Util::split_header_words($content_type);
die "Multiple Content-Type headers!" if @v > 1;
@v = @v[0];
my ($boundary, $boundary_index);
my @tmp = @v;
for @tmp -> $k, $v {
if ($k.lc() eq "boundary") {
$boundary = $v;
$boundary_index = @v - @tmp - 1;
last;
}
}
my @parts = @!parts.map({ .as_string($CRLF) });
my $bno = 0;
$boundary //= $self!boundary;
# XXX need to do the CHECK_BOUNDARY bit
if ($boundary_index) {
@v[$boundary_index] = $boundary;
} else {
@v.push(boundary => "boundary");
}
$content_type = HTTP::Headers::Util::join_header_words(@v);
$self.header("Content-Type", $content_type);
$self!set_content("--$boundary$CRLF" ~ @parts.join("$CRLF--boundary$CRLF") ~ "$CRLF--$boundary$CRLF", 1);
}
my method boundary (Num ?$size) returns Str {
if (!$size) { return "xYzZY"; }
my $b;
# XXX use MIME::Base64::encode
#$b = MIME::Base64::encode([~] (1..($size * 3).map:{ chr(rand(256)) }), "");
$b ~~ s:g/\W+/X/; # ensure alnum only
return $b;
}
multi sub *coerce:<as> (::?CLASS $self, Str ::to) {
$self.as_string("\n");
}