message.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

package HTTP::Message;

# $Id: Message.pm,v 1.57 2005/02/18 20:29:01 gisle Exp $

use strict;
use vars qw($VERSION $AUTOLOAD);
$VERSION = sprintf("%d.%02d", q$Revision: 1.57 $ =~ /(\d+)\.(\d+)/);

require HTTP::Headers;
require Carp;

my $CRLF = "\015\012";   # "\r\n" is not portable
$HTTP::URI_CLASS ||= $ENV{PERL_HTTP_URI_CLASS} || "URI";
eval "require $HTTP::URI_CLASS"; die $@ if $@;



sub new
{
    my($class, $header, $content) = @_;
    if (defined $header) {
	Carp::croak("Bad header argument") unless ref $header;
        if (ref($header) eq "ARRAY") {
	    $header = HTTP::Headers->new(@$header);
	}
	else {
	    $header = $header->clone;
	}
    }
    else {
	$header = HTTP::Headers->new;
    }
    $content = '' unless defined $content;

    bless {
	'_headers' => $header,
	'_content' => $content,
    }, $class;
}


sub parse
{
    my($class, $str) = @_;

    my @hdr;
    while (1) {
	if ($str =~ s/^([^\s:]+)[ \t]*: ?(.*)\n?//) {
	    push(@hdr, $1, $2);
	    $hdr[-1] =~ s/\r\z//;
	}
	elsif (@hdr && $str =~ s/^([ \t].*)\n?//) {
	    $hdr[-1] .= "\n$1";
	    $hdr[-1] =~ s/\r\z//;
	}
	else {
	    $str =~ s/^\r?\n//;
	    last;
	}
    }

    new($class, \@hdr, $str);
}


sub clone
{
    my $self  = shift;
    my $clone = HTTP::Message->new($self->headers,
				   $self->content);
    $clone->protocol($self->protocol);
    $clone;
}


sub clear {
    my $self = shift;
    $self->{_headers}->clear;
    $self->content("");
    delete $self->{_parts};
    return;
}


sub protocol { shift->_elem('_protocol',  @_); }

sub content  {

    my $self = $_[0];
    if (defined(wantarray)) {
	$self->_content unless exists $self->{_content};
	my $old = $self->{_content};
	$old = $$old if ref($old) eq "SCALAR";
	&_set_content if @_ > 1;
	return $old;
    }

    if (@_ > 1) {
	&_set_content;
    }
    else {
	Carp::carp("Useless content call in void context") if $^W;
    }
}

sub _set_content {
    my $self = $_[0];
    if (!ref($_[1]) && ref($self->{_content}) eq "SCALAR") {
	${$self->{_content}} = $_[1];
    }
    else {
	die "Can't set content to be a scalar reference" if ref($_[1]) eq "SCALAR";
	$self->{_content} = $_[1];
	delete $self->{_content_ref};
    }
    delete $self->{_parts} unless $_[2];
}


sub add_content
{
    my $self = shift;
    $self->_content unless exists $self->{_content};
    my $chunkref = \$_[0];
    $chunkref = $$chunkref if ref($$chunkref);  # legacy

    my $ref = ref($self->{_content});
    if (!$ref) {
	$self->{_content} .= $$chunkref;
    }
    elsif ($ref eq "SCALAR") {
	${$self->{_content}} .= $$chunkref;
    }
    else {
	Carp::croak("Can't append to $ref content");
    }
    delete $self->{_parts};
}


sub content_ref
{
    my $self = shift;
    $self->_content unless exists $self->{_content};
    delete $self->{_parts};
    my $old = \$self->{_content};
    my $old_cref = $self->{_content_ref};
    if (@_) {
	my $new = shift;
	Carp::croak("Setting content_ref to a non-ref") unless ref($new);
	delete $self->{_content};  # avoid modifying $$old
	$self->{_content} = $new;
	$self->{_content_ref}++;
    }
    $old = $$old if $old_cref;
    return $old;
}


sub decoded_content
{
    my($self, %opt) = @_;
    my $content_ref;
    my $content_ref_iscopy;

    eval {

	require HTTP::Headers::Util;
	my($ct, %ct_param);
	if (my @ct = HTTP::Headers::Util::split_header_words($self->header("Content-Type"))) {
	    ($ct, undef, %ct_param) = @{$ct[-1]};
	    $ct = lc($ct);

	    die "Can't decode multipart content" if $ct =~ m,^multipart/,;
	}

	$content_ref = $self->content_ref;
	die "Can't decode ref content" if ref($content_ref) ne "SCALAR";

	if (my $h = $self->header("Content-Encoding")) {
	    $h =~ s/^\s+//;
	    $h =~ s/\s+$//;
	    for my $ce (reverse split(/\s*,\s*/, lc($h))) {
		next unless $ce || $ce eq "identity";
		if ($ce eq "gzip" || $ce eq "x-gzip") {
		    require Compress::Zlib;
		    unless ($content_ref_iscopy) {
			# memGunzip is documented to destroy its buffer argument
			my $copy = $$content_ref;
			$content_ref = \$copy;
			$content_ref_iscopy++;
		    }
		    $content_ref = \Compress::Zlib::memGunzip($$content_ref);
		    die "Can't gunzip content" unless defined $$content_ref;
		}
		elsif ($ce eq "x-bzip2") {
		    require Compress::Bzip2;
		    $content_ref = Compress::Bzip2::decompress($$content_ref);
		    die "Can't bunzip content" unless defined $$content_ref;
		    $content_ref_iscopy++;
		}
		elsif ($ce eq "deflate") {
		    require Compress::Zlib;
		    my $out = Compress::Zlib::uncompress($$content_ref);
		    unless (defined $out) {
			# "Content-Encoding: deflate" is supposed to mean the "zlib"
                        # format of RFC 1950, but Microsoft got that wrong, so some
                        # servers sends the raw compressed "deflate" data.  This
                        # tries to inflate this format.
			unless ($content_ref_iscopy) {
			    # the $i->inflate method is documented to destroy its
			    # buffer argument
			    my $copy = $$content_ref;
			    $content_ref = \$copy;
			    $content_ref_iscopy++;
			}

			my($i, $status) = Compress::Zlib::inflateInit(
			    WindowBits => -Compress::Zlib::MAX_WBITS(),
                        );
			my $OK = Compress::Zlib::Z_OK();
			die "Can't init inflate object" unless $i && $status == $OK;
			($out, $status) = $i->inflate($content_ref);
			if ($status != Compress::Zlib::Z_STREAM_END()) {
			    if ($status == $OK) {
				$self->push_header("Client-Warning" =>
				    "Content might be truncated; incomplete deflate stream");
			    }
			    else {
				# something went bad, can't trust $out any more
				$out = undef;
			    }
			}
		    }
		    die "Can't inflate content" unless defined $out;
		    $content_ref = \$out;
		    $content_ref_iscopy++;
		}
		elsif ($ce eq "compress" || $ce eq "x-compress") {
		    die "Can't uncompress content";
		}
		elsif ($ce eq "base64") {  # not really C-T-E, but should be harmless
		    require MIME::Base64;
		    $content_ref = \MIME::Base64::decode($$content_ref);
		    $content_ref_iscopy++;
		}
		elsif ($ce eq "quoted-printable") { # not really C-T-E, but should be harmless
		    require MIME::QuotedPrint;
		    $content_ref = \MIME::QuotedPrint::decode($$content_ref);
		    $content_ref_iscopy++;
		}
		else {
		    die "Don't know how to decode Content-Encoding '$ce'";
		}
	    }
	}

	if ($ct && $ct =~ m,^text/,,) {
	    my $charset = $opt{charset} || $ct_param{charset} || $opt{default_charset} || "ISO-8859-1";
	    $charset = lc($charset);
	    if ($charset ne "none") {
		require Encode;
		if (do{my $v = $Encode::VERSION; $v =~ s/_//g; $v} < 2.0901 &&
		    !$content_ref_iscopy)
		{
		    # LEAVE_SRC did not work before Encode-2.0901
		    my $copy = $$content_ref;
		    $content_ref = \$copy;
		    $content_ref_iscopy++;
		}
		$content_ref = \Encode::decode($charset, $$content_ref,
					       Encode::FB_CROAK() | Encode::LEAVE_SRC());
	    }
	}
    };
    if ($@) {
	Carp::croak($@) if $opt{raise_error};
	return undef;
    }

    return $opt{ref} ? $content_ref : $$content_ref;
}


sub as_string
{
    my($self, $eol) = @_;
    $eol = "\n" unless defined $eol;

    # The calculation of content might update the headers
    # so we need to do that first.
    my $content = $self->content;

    return join("", $self->{'_headers'}->as_string($eol),
		    $eol,
		    $content,
		    (@_ == 1 && length($content) &&
		     $content !~ /\n\z/) ? "\n" : "",
		);
}


sub headers            { shift->{'_headers'};                }
sub headers_as_string  { shift->{'_headers'}->as_string(@_); }


sub parts {
    my $self = shift;
    if (defined(wantarray) && (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR")) {
	$self->_parts;
    }
    my $old = $self->{_parts};
    if (@_) {
	my @parts = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_;
	my $ct = $self->content_type || "";
	if ($ct =~ m,^message/,) {
	    Carp::croak("Only one part allowed for $ct content")
		if @parts > 1;
	}
	elsif ($ct !~ m,^multipart/,) {
	    $self->remove_content_headers;
	    $self->content_type("multipart/mixed");
	}
	$self->{_parts} = \@parts;
	_stale_content($self);
    }
    return @$old if wantarray;
    return $old->[0];
}

sub add_part {
    my $self = shift;
    if (($self->content_type || "") !~ m,^multipart/,) {
	my $p = HTTP::Message->new($self->remove_content_headers,
				   $self->content(""));
	$self->content_type("multipart/mixed");
	$self->{_parts} = [$p];
    }
    elsif (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR") {
	$self->_parts;
    }

    push(@{$self->{_parts}}, @_);
    _stale_content($self);
    return;
}

sub _stale_content {
    my $self = shift;
    if (ref($self->{_content}) eq "SCALAR") {
	# must recalculate now
	$self->_content;
    }
    else {
	# just invalidate cache
	delete $self->{_content};
	delete $self->{_content_ref};
    }
}


# delegate all other method calls the the _headers object.
sub AUTOLOAD
{
    my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
    return if $method eq "DESTROY";