lite.pm

1. 记录每个帖子的访问人情况

  my $clone = bless {} => ref($self) || $self;
  foreach (keys %$self) {
    my $value = $self->{$_};
    $clone->{$_} = ref $value && UNIVERSAL::isa($value => __PACKAGE__) ? $value->clone : $value;
  }
  $clone;
}

# ======================================================================

package SOAP::Transport;

use vars qw($AUTOLOAD @ISA);

@ISA = qw(SOAP::Cloneable);

sub DESTROY { SOAP::Trace::objects('()') }

sub new { 
  my $self = shift;
  my $class = ref($self) || $self;
  return $self if ref $self;

  SOAP::Trace::objects('()');
  return bless {} => $class;
}

sub proxy {
  my $self = shift->new;
  my $class = ref $self;

  return $self->{_proxy} unless @_;
  $_[0] =~ /^(\w+):/ or die "proxy: transport protocol not specified\n";
  my $protocol = uc "$1"; # untainted now
  # https: should be done through Transport::HTTP.pm
  for ($protocol) { s/^HTTPS$/HTTP/ }

  (my $protocol_class = "${class}::$protocol") =~ s/-/_/g;
  no strict 'refs';
  unless (defined %{"$protocol_class\::Client::"} && UNIVERSAL::can("$protocol_class\::Client" => 'new')) {
    eval "require $protocol_class";
    die "Unsupported protocol '$protocol'\n" if $@ =~ m!^Can't locate SOAP/Transport/!;
    die if $@;
  }
  $protocol_class .= "::Client";
  return $self->{_proxy} = $protocol_class->new(endpoint => shift, @_);
}

sub AUTOLOAD {
  my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2);
  return if $method eq 'DESTROY';

  no strict 'refs';
  *$AUTOLOAD = sub { shift->proxy->$method(@_) };
  goto &$AUTOLOAD;
}

# ======================================================================

package SOAP::Fault;

use Carp ();

use overload fallback => 1, '""' => "stringify";

sub DESTROY { SOAP::Trace::objects('()') }

sub new { 
  my $self = shift;

  unless (ref $self) {
    my $class = ref($self) || $self;
    $self = bless {} => $class;
    SOAP::Trace::objects('()');
  }

  Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1); 
  while (@_) { my $method = shift; $self->$method(shift) if $self->can($method) }

  return $self;
}

sub stringify {
  my $self = shift;
  return join ': ', $self->faultcode, $self->faultstring;
}

sub BEGIN {
  no strict 'refs';
  for my $method (qw(faultcode faultstring faultactor faultdetail)) {
    my $field = '_' . $method;
    *$method = sub {
      my $self = UNIVERSAL::isa($_[0] => __PACKAGE__) ? shift->new : __PACKAGE__->new;
      if (@_) { $self->{$field} = shift; return $self }
      return $self->{$field};
    }
  }
  *detail = \&faultdetail;
}

# ======================================================================

package SOAP::Data;

use vars qw(@ISA @EXPORT_OK);
use Exporter;
use Carp ();

@ISA = qw(Exporter);
@EXPORT_OK = qw(name type attr value uri);

sub DESTROY { SOAP::Trace::objects('()') }

sub new { 
  my $self = shift;

  unless (ref $self) {
    my $class = ref($self) || $self;
    $self = bless {_attr => {}, _value => [], _signature => []} => $class;
    SOAP::Trace::objects('()');
  }

  Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1); 
  while (@_) { my $method = shift; $self->$method(shift) if $self->can($method) }

  return $self;
}

sub name {
  my $self = UNIVERSAL::isa($_[0] => __PACKAGE__) ? shift->new : __PACKAGE__->new;
  if (@_) { 
    my($name, $uri, $prefix) = shift;
    if ($name) {
      ($uri, $name) = SOAP::Utils::splitlongname($name);
      unless (defined $uri) { 
        ($prefix, $name) = SOAP::Utils::splitqname($name);
        $self->prefix($prefix) if defined $prefix;
      } else {
        $self->uri($uri);
      }
    }
    $self->{_name} = $name;

    $self->value(@_) if @_; 
    return $self;
  }
  return $self->{_name};
}

sub attr {
  my $self = UNIVERSAL::isa($_[0] => __PACKAGE__) ? shift->new : __PACKAGE__->new;
  if (@_) { $self->{_attr} = shift; $self->value(@_) if @_; return $self }
  return $self->{_attr};
}

sub type {
  my $self = UNIVERSAL::isa($_[0] => __PACKAGE__) ? shift->new : __PACKAGE__->new;
  if (@_) { 
    $self->{_type} = shift; 
    $self->value(@_) if @_; 
    return $self;
  }
  if (!defined $self->{_type} && (my @types = grep {/^\{$SOAP::Constants::NS_XSI_ALL}type$/o} keys %{$self->{_attr}})) {
    $self->{_type} = (SOAP::Utils::splitlongname(delete $self->{_attr}->{shift(@types)}))[1];
  }
  return $self->{_type};
}

BEGIN {
  no strict 'refs';
  for my $method (qw(root mustUnderstand)) {
    my $field = '_' . $method;
    *$method = sub {
      my $attr = $method eq 'root' ? "{$SOAP::Constants::NS_ENC}$method" : "{$SOAP::Constants::NS_ENV}$method";
      my $self = UNIVERSAL::isa($_[0] => __PACKAGE__) ? shift->new : __PACKAGE__->new;
      if (@_) {
        $self->{_attr}->{$attr} = $self->{$field} = shift() ? 1 : 0; 
        $self->value(@_) if @_; 
        return $self;
      }
      $self->{$field} = SOAP::XMLSchemaSOAP1_2::Deserializer->as_boolean($self->{_attr}->{$attr})
        if !defined $self->{$field} && defined $self->{_attr}->{$attr}; 
      return $self->{$field};
    }
  }
  for my $method (qw(actor encodingStyle)) {
    my $field = '_' . $method;
    *$method = sub {
      my $attr = "{$SOAP::Constants::NS_ENV}$method";
      my $self = UNIVERSAL::isa($_[0] => __PACKAGE__) ? shift->new : __PACKAGE__->new;
      if (@_) {
        $self->{_attr}->{$attr} = $self->{$field} = shift;
        $self->value(@_) if @_;
        return $self;
      }
      $self->{$field} = $self->{_attr}->{$attr}
        if !defined $self->{$field} && defined $self->{_attr}->{$attr}; 
      return $self->{$field};
    }
  }
}

sub prefix {
  my $self = UNIVERSAL::isa($_[0] => __PACKAGE__) ? shift->new : __PACKAGE__->new;
  return $self->{_prefix} unless @_;
  $self->{_prefix} = shift; 
  $self->value(@_) if @_;
  return $self;
}

sub uri {
  my $self = UNIVERSAL::isa($_[0] => __PACKAGE__) ? shift->new : __PACKAGE__->new;
  return $self->{_uri} unless @_;
  my $uri = $self->{_uri} = shift; 
  warn "Usage of '::' in URI ($uri) deprecated. Use '/' instead\n"
    if defined $uri && $^W && $uri =~ /::/;
  $self->value(@_) if @_;
  return $self;
}

sub set_value {
  my $self = UNIVERSAL::isa($_[0] => __PACKAGE__) ? shift->new : __PACKAGE__->new;
  $self->{_value} = [@_];
  return $self; 
}

sub value {
  my $self = UNIVERSAL::isa($_[0] => __PACKAGE__) ? shift->new : __PACKAGE__->new;
  @_ ? ($self->set_value(@_), return $self) 
     : wantarray ? return @{$self->{_value}} : return $self->{_value}->[0];
}

sub signature {
  my $self = UNIVERSAL::isa($_[0] => __PACKAGE__) ? shift->new : __PACKAGE__->new;
  @_ ? ($self->{_signature} = shift, return $self) : (return $self->{_signature});
}

# ======================================================================

package SOAP::Header;

use vars qw(@ISA);
@ISA = qw(SOAP::Data);

# ======================================================================

package SOAP::Serializer;

use Carp ();
use vars qw(@ISA);

@ISA = qw(SOAP::Cloneable SOAP::XMLSchema::Serializer);

BEGIN {
  # namespaces and anonymous data structures
  my $ns   = 0; 
  my $name = 0; 
  my $prefix = 'c-';
  sub gen_ns { 'namesp' . ++$ns } 
  sub gen_name { join '', $prefix, 'gensym', ++$name } 
  sub prefix { $prefix =~ s/^[^\-]+-/$_[1]-/; $_[0]; }
}

sub DESTROY { SOAP::Trace::objects('()') }

sub new { 
  my $self = shift;

  unless (ref $self) {
    my $class = ref($self) || $self;
    $self = bless {
      _level => 0,
      _autotype => 1,
      _readable => 0,
      _multirefinplace => 0,
      _seen => {},
      _typelookup => {
        base64 => [10, sub {$_[0] =~ /[^\x09\x0a\x0d\x20-\x7f]/}, 'as_base64'],
        int    => [20, sub {$_[0] =~ /^[+-]?\d+$/}, 'as_int'],
        float  => [30, sub {$_[0] =~ /^(-?(?:\d+(?:\.\d*)?|\.\d+|NaN|INF)|([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?)$/}, 'as_float'],
        string => [40, sub {1}, 'as_string'],
      },
      _encoding => 'UTF-8',
      _objectstack => {},
      _signature => [],
      _maptype => {SOAPStruct => $SOAP::Constants::NS_APS},
      _on_nonserialized => sub {Carp::carp "Cannot marshall @{[ref shift]} reference" if $^W; return},
      _attr => {
        "{$SOAP::Constants::NS_ENV}encodingStyle" => $SOAP::Constants::NS_ENC,
      },
      _namespaces => {
        $SOAP::Constants::NS_ENC => $SOAP::Constants::PREFIX_ENC,
        $SOAP::Constants::PREFIX_ENV ? ($SOAP::Constants::NS_ENV => $SOAP::Constants::PREFIX_ENV) : (),
      },
      _soapversion => SOAP::Lite->soapversion,
    } => $class;

    $self->xmlschema($SOAP::Constants::DEFAULT_XML_SCHEMA);

    SOAP::Trace::objects('()');
  }

  Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1); 
  while (@_) { my $method = shift; $self->$method(shift) if $self->can($method) }

  return $self;
}

sub soapversion {
  my $self = shift;
  return $self->{_soapversion} unless @_;
  return $self if $self->{_soapversion} eq SOAP::Lite->soapversion;
  $self->{_soapversion} = shift;

  $self->attr({
    "{$SOAP::Constants::NS_ENV}encodingStyle" => $SOAP::Constants::NS_ENC,
  });
  $self->namespaces({
    $SOAP::Constants::NS_ENC => $SOAP::Constants::PREFIX_ENC,
    $SOAP::Constants::PREFIX_ENV ? ($SOAP::Constants::NS_ENV => $SOAP::Constants::PREFIX_ENV) : (),
  });
  $self->xmlschema($SOAP::Constants::DEFAULT_XML_SCHEMA);

  $self;
}

sub xmlschema {
  my $self = shift->new;
  return $self->{_xmlschema} unless @_;

  my @schema;
  if ($_[0]) {
    @schema = grep {/XMLSchema/ && /$_[0]/} keys %SOAP::Constants::XML_SCHEMAS;
    Carp::croak "More than one schema match parameter '$_[0]': @{[join ', ', @schema]}" if @schema > 1;
    Carp::croak "No schema match parameter '$_[0]'" if @schema != 1;
  }

  # do nothing if current schema is the same as new
  return $self if $self->{_xmlschema} && $self->{_xmlschema} eq $schema[0];

  my $ns = $self->namespaces;

  # delete current schema from namespaces
  if (my $schema = $self->{_xmlschema}) {
    delete $ns->{$schema};
    delete $ns->{"$schema-instance"};
  }

  # add new schema into namespaces
  if (my $schema = $self->{_xmlschema} = shift @schema) {
    $ns->{$schema} = 'xsd';
    $ns->{"$schema-instance"} = 'xsi';
  }

  # and here is the class serializer should work with
  my $class = exists $SOAP::Constants::XML_SCHEMAS{$self->{_xmlschema}} ?
    $SOAP::Constants::XML_SCHEMAS{$self->{_xmlschema}} . '::Serializer' : $self;

  $self->xmlschemaclass($class);

  return $self;
}

sub namespace {
  Carp::carp "'SOAP::Serializer->namespace' method is deprecated. Instead use '->envprefix'" if $^W;
  shift->envprefix(@_);
}

sub encodingspace {
  Carp::carp "'SOAP::Serializer->encodingspace' method is deprecated. Instead use '->encprefix'" if $^W;
  shift->encprefix(@_);
}

sub envprefix {
  my $self = shift->new;
  return $self->namespaces->{$SOAP::Constants::NS_ENV} unless @_;
  $self->namespaces->{$SOAP::Constants::NS_ENV} = shift;
  return $self;
}

sub encprefix {
  my $self = shift->new;
  return $self->namespaces->{$SOAP::Constants::NS_ENC} unless @_;
  $self->namespaces->{$SOAP::Constants::NS_ENC} = shift;
  return $self;
}

sub BEGIN {
  no strict 'refs';
  for my $method (qw(readable level seen autotype typelookup uri attr maptype
                     namespaces multirefinplace encoding signature
                     on_nonserialized)) {
    my $field = '_' . $method;
    *$method = sub {
      my $self = shift->new;