diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/HTTP/Message.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/HTTP/Message.pm | 83 |
1 files changed, 41 insertions, 42 deletions
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Message.pm b/Master/tlpkg/tlperl/lib/HTTP/Message.pm index 4aae3f2c8a1..3eeebfbfd3b 100644 --- a/Master/tlpkg/tlperl/lib/HTTP/Message.pm +++ b/Master/tlpkg/tlperl/lib/HTTP/Message.pm @@ -2,13 +2,20 @@ package HTTP::Message; use strict; use vars qw($VERSION $AUTOLOAD); -$VERSION = "6.03"; +$VERSION = "6.06"; require HTTP::Headers; require Carp; my $CRLF = "\015\012"; # "\r\n" is not portable -$HTTP::URI_CLASS ||= $ENV{PERL_HTTP_URI_CLASS} || "URI"; +unless ($HTTP::URI_CLASS) { + if ($ENV{PERL_HTTP_URI_CLASS} + && $ENV{PERL_HTTP_URI_CLASS} =~ /^([\w:]+)$/) { + $HTTP::URI_CLASS = $1; + } else { + $HTTP::URI_CLASS = "URI"; + } +} eval "require $HTTP::URI_CLASS"; die $@ if $@; *_utf8_downgrade = defined(&utf8::downgrade) ? @@ -207,10 +214,10 @@ sub content_charset # Unicode BOM for ($$cref) { return "UTF-8" if /^\xEF\xBB\xBF/; - return "UTF-32-LE" if /^\xFF\xFE\x00\x00/; - return "UTF-32-BE" if /^\x00\x00\xFE\xFF/; - return "UTF-16-LE" if /^\xFF\xFE/; - return "UTF-16-BE" if /^\xFE\xFF/; + return "UTF-32LE" if /^\xFF\xFE\x00\x00/; + return "UTF-32BE" if /^\x00\x00\xFE\xFF/; + return "UTF-16LE" if /^\xFF\xFE/; + return "UTF-16BE" if /^\xFE\xFF/; } if ($self->content_is_xml) { @@ -219,10 +226,10 @@ sub content_charset # in UTF-8 or UTF-16 encoding must begin with an XML encoding declaration, # in which the first characters must be '<?xml' for ($$cref) { - return "UTF-32-BE" if /^\x00\x00\x00</; - return "UTF-32-LE" if /^<\x00\x00\x00/; - return "UTF-16-BE" if /^(?:\x00\s)*\x00</; - return "UTF-16-LE" if /^(?:\s\x00)*<\x00/; + return "UTF-32BE" if /^\x00\x00\x00</; + return "UTF-32LE" if /^<\x00\x00\x00/; + return "UTF-16BE" if /^(?:\x00\s)*\x00</; + return "UTF-16LE" if /^(?:\s\x00)*<\x00/; if (/^\s*(<\?xml[^\x00]*?\?>)/) { if ($1 =~ /\sencoding\s*=\s*(["'])(.*?)\1/) { my $enc = $2; @@ -236,34 +243,21 @@ sub content_charset elsif ($self->content_is_html) { # look for <META charset="..."> or <META content="..."> # http://dev.w3.org/html5/spec/Overview.html#determining-the-character-encoding - my $charset; - require HTML::Parser; - my $p = HTML::Parser->new( - start_h => [sub { - my($tag, $attr, $self) = @_; - $charset = $attr->{charset}; - unless ($charset) { - # look at $attr->{content} ... - if (my $c = $attr->{content}) { - require HTTP::Headers::Util; - my @v = HTTP::Headers::Util::split_header_words($c); - return unless @v; - my($ct, undef, %ct_param) = @{$v[0]}; - $charset = $ct_param{charset}; - } - return unless $charset; - } - if ($charset =~ /^utf-?16/i) { - # converted document, assume UTF-8 - $charset = "UTF-8"; - } - $self->eof; - }, "tagname, attr, self"], - report_tags => [qw(meta)], - utf8_mode => 1, - ); - $p->parse($$cref); - return $charset if $charset; + require IO::HTML; + # Use relaxed search to match previous versions of HTTP::Message: + my $encoding = IO::HTML::find_charset_in($$cref, { encoding => 1, + need_pragma => 0 }); + return $encoding->mime_name if $encoding; + } + elsif ($self->content_type eq "application/json") { + for ($$cref) { + # RFC 4627, ch 3 + return "UTF-32BE" if /^\x00\x00\x00./s; + return "UTF-32LE" if /^.\x00\x00\x00/s; + return "UTF-16BE" if /^\x00.\x00./s; + return "UTF-16LE" if /^.\x00.\x00/s; + return "UTF-8"; + } } if ($self->content_type =~ /^text\//) { for ($$cref) { @@ -557,13 +551,14 @@ sub dump $content =~ s/(\n+)\n/("\\n" x length($1)) . "\n"/eg; $content =~ s/\n\z/\\n/; - my $no_content = "(no content)"; + my $no_content = $opt{no_content}; + $no_content = "(no content)" unless defined $no_content; if ($content eq $no_content) { # escape our $no_content marker $content =~ s/^(.)/sprintf('\\x%02X',ord($1))/eg; } elsif ($content eq "") { - $content = "(no content)"; + $content = $no_content; } } @@ -646,7 +641,7 @@ sub AUTOLOAD # We create the function here so that it will not need to be # autoloaded the next time. no strict 'refs'; - *$method = sub { shift->headers->$method(@_) }; + *$method = sub { local $Carp::Internal{+__PACKAGE__} = 1; shift->headers->$method(@_) }; goto &$method; } @@ -676,7 +671,7 @@ sub _parts { my %h = @{$h[0]}; if (defined(my $b = $h{boundary})) { my $str = $self->content; - $str =~ s/\r?\n--\Q$b\E--\r?\n.*//s; + $str =~ s/\r?\n--\Q$b\E--.*//s; if ($str =~ s/(^|.*?\r?\n)--\Q$b\E\r?\n//s) { $self->{_parts} = [map HTTP::Message->parse($_), split(/\r?\n--\Q$b\E\r?\n/, $str)] @@ -1057,6 +1052,10 @@ for unlimited. If the content is longer then the string is chopped at the limit and the string "...\n(### more bytes not shown)" appended. +=item no_content => $str + +Replaces the "(no content)" marker. + =item prefix => $str A string that will be prefixed to each line of the dump. |