lite.pm

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

      @_ ? ($self->{$field} = shift, return $self) : return $self->{$field};
    }
  }
  for my $method (qw(method fault freeform)) { # aliases for envelope
    *$method = sub { shift->envelope($method => @_) }
  }
  for my $method (qw(qualify overqualify disqualify)) { # import from SOAP::Utils
    *$method = \&{'SOAP::Utils::'.$method};
  }
}

sub gen_id { sprintf "%U", $_[1] }

sub multiref_object {
  my $self = shift;
  my $object = shift;
  my $id = $self->gen_id($object);
  my $seen = $self->seen;
  $seen->{$id}->{count}++;
  $seen->{$id}->{multiref} ||= $seen->{$id}->{count} > 1;
  $seen->{$id}->{value} = $object;
  $seen->{$id}->{recursive} ||= 0;
  return $id;
}

sub recursive_object { 
  my $self = shift; 
  $self->seen->{$self->gen_id(shift)}->{recursive} = 1;
}

sub is_href { 
  my $self = shift;
  my $seen = $self->seen->{shift || return} or return;
  return 1 if $seen->{id};
  return $seen->{multiref} &&
         !($seen->{id} = (shift || 
                          $seen->{recursive} || 
                          $seen->{multiref} && $self->multirefinplace));
}

sub multiref_anchor { 
  my $seen = shift->seen->{my $id = shift || return undef};
  return $seen->{multiref} ? "ref-$id" : undef;
}

sub encode_multirefs {
  my $self = shift;
  return if $self->multirefinplace;

  my $seen = $self->seen;
  map { $_->[1]->{_id} = 1; $_ 
      } map { $self->encode_object($seen->{$_}->{value}) 
            } grep { $seen->{$_}->{multiref} && !$seen->{$_}->{recursive}
                   } keys %$seen;
}

# ----------------------------------------------------------------------

sub maptypetouri {
  my($self, $type, $simple) = @_;

  return $type unless defined $type;
  my($prefix, $name) = SOAP::Utils::splitqname($type);

  unless (defined $prefix) {
    $name =~ s/__|\./::/g;
    $self->maptype->{$name} = $simple 
        ? die "Schema/namespace for type '$type' is not specified\n"
        : $SOAP::Constants::NS_SL_PERLTYPE
      unless exists $self->maptype->{$name};
    $type = $self->maptype->{$name} 
      ? qualify($self->namespaces->{$self->maptype->{$name}} ||= gen_ns, $type)
      : undef;
  }
  return $type;
}

sub encode_object {
  my($self, $object, $name, $type, $attr) = @_;

  $attr ||= {};

  return $self->encode_scalar($object, $name, $type, $attr) unless ref $object;

  my $id = $self->multiref_object($object); 

  use vars '%objectstack';           # we'll play with symbol table 
  local %objectstack = %objectstack; # want to see objects ONLY in the current tree
  # did we see this object in current tree? Seems to be recursive refs
  $self->recursive_object($object) if ++$objectstack{$id} > 1;
  # return if we already saw it twice. It should be already properly serialized
  return if $objectstack{$id} > 2;

  if (UNIVERSAL::isa($object => 'SOAP::Data')) { 
    # use $object->SOAP::Data:: to enable overriding name() and others in inherited classes
    $object->SOAP::Data::name($name) unless defined $object->SOAP::Data::name;

    # apply ->uri() and ->prefix() which can modify name and attributes of
    # element, but do not modify SOAP::Data itself
    my($name, $attr) = $self->fixattrs($object);
    $attr = $self->attrstoqname($attr);

    my @realvalues = $object->SOAP::Data::value;
    return [$name || gen_name, $attr] unless @realvalues;

    my $method = "as_" . ($object->SOAP::Data::type || '-'); # dummy type if not defined
    # try to call method specified for this type
    my @values = map { 
      # store null/nil attribute if value is undef
      $attr->{qualify(xsi => $self->xmlschemaclass->nilValue)} = $self->xmlschemaclass->as_undef(1)
        unless defined;
         $self->can($method) && $self->$method($_, $name || gen_name, $object->SOAP::Data::type, $attr)
      || $self->typecast($_, $name || gen_name, $object->SOAP::Data::type, $attr)
      || $self->encode_object($_, $name, $object->SOAP::Data::type, $attr)
    } @realvalues;
    $object->SOAP::Data::signature([map {join $;, $_->[0], disqualify($_->[1]->{'xsi:type'} || '')} @values]) if @values;
    return wantarray ? @values : $values[0];
  } 

  my $class = ref $object;
  if ($class !~ /^(?:SCALAR|ARRAY|HASH|REF)$/o) { 
    # we could also check for CODE|GLOB|LVALUE, but we cannot serialize 
    # them anyway, so they'll be cought by check below
    $class =~ s/::/__/g;

    $name = $class if !defined $name;
    $type = $class if !defined $type && $self->autotype;

    my $method = 'as_' . $class;
    if ($self->can($method)) {
      my $encoded = $self->$method($object, $name, $type, $attr);
      return $encoded if ref $encoded;
      # return only if handled, otherwise handle with default handlers
    }
  }

  return 
    UNIVERSAL::isa($object => 'REF') ||
    UNIVERSAL::isa($object => 'SCALAR') ? $self->encode_scalar($object, $name, $type, $attr) :
    UNIVERSAL::isa($object => 'ARRAY')  ? $self->encode_array($object, $name, $type, $attr) :
    UNIVERSAL::isa($object => 'HASH')   ? $self->encode_hash($object, $name, $type, $attr) :
                                          $self->on_nonserialized->($object); 
}

sub encode_scalar {
  my($self, $value, $name, $type, $attr) = @_;
  $name ||= gen_name;

  my $schemaclass = $self->xmlschemaclass;

  # null reference
  return [$name, {%$attr, qualify(xsi => $schemaclass->nilValue) => $schemaclass->as_undef(1)}] unless defined $value;

  # object reference
  return [$name, {'xsi:type' => $self->maptypetouri($type), %$attr}, [$self->encode_object($$value)], $self->gen_id($value)] if ref $value;

  # autodefined type 
  if ($self->autotype) {
    my $lookup = $self->typelookup;
    for (sort {$lookup->{$a}->[0] <=> $lookup->{$b}->[0]} keys %$lookup) {
      my $method = $lookup->{$_}->[2];
      return $self->can($method) && $self->$method($value, $name, $type, $attr)
          || $method->($value, $name, $type, $attr)
        if $lookup->{$_}->[1]->($value);
    }
  }

  # invariant
  return [$name, $attr, $value];
}

sub encode_array {
  my($self, $array, $name, $type, $attr) = @_;
  my $items = 'item'; 

# TD: add support for multidimensional, partially transmitted and sparse arrays
  my @items = map {$self->encode_object($_, $items)} @$array;
  my $num = @items;
  my($arraytype, %types) = '-';
  for (@items) { $arraytype = $_->[1]->{'xsi:type'} || '-'; $types{$arraytype}++ }
  $arraytype = sprintf "%s\[$num]", keys %types > 1 || $arraytype eq '-' ? qualify(xsd => $self->xmlschemaclass->anyTypeValue) : $arraytype;

  $type = qualify($self->encprefix => 'Array') if $self->autotype && !defined $type;

  return [$name || qualify($self->encprefix => 'Array'), 
          {qualify($self->encprefix => 'arrayType') => $arraytype, 'xsi:type' => $self->maptypetouri($type), %$attr},
          [@items], 
          $self->gen_id($array)
  ];
}

sub encode_hash {
  my($self, $hash, $name, $type, $attr) = @_;

  if ($self->autotype && grep {!/$SOAP::Constants::ELMASK/o} keys %$hash) {
    warn qq!Cannot encode @{[$name ? "'$name'" : 'unnamed']} element as 'hash'. Will be encoded as 'map' instead\n! if $^W;
    return $self->as_map($hash, $name || gen_name, $type, $attr);
  }

  $type = 'SOAPStruct' if $self->autotype && !defined $type && exists $self->maptype->{SOAPStruct};
  return [$name || gen_name, 
          {'xsi:type' => $self->maptypetouri($type), %$attr},
          [map {$self->encode_object($hash->{$_}, $_)} keys %$hash], 
          $self->gen_id($hash)
  ];
}

# ----------------------------------------------------------------------

sub as_ordered_hash {
  my $self = shift;
  my($value, $name, $type, $attr) = @_;
  die "Not an ARRAY reference for 'ordered_hash' type" unless UNIVERSAL::isa($value => 'ARRAY');
  return [$name, $attr, 
    [map{$self->encode_object(@{$value}[2*$_+1,2*$_])} 0..$#$value/2], 
    $self->gen_id($value)
  ];
}

sub as_map {
  my $self = shift;
  my($value, $name, $type, $attr) = @_;
  die "Not a HASH reference for 'map' type" unless UNIVERSAL::isa($value => 'HASH');
  my $prefix = ($self->namespaces->{$SOAP::Constants::NS_APS} ||= 'xmlsoap');
  my @items = map {$self->encode_object(SOAP::Data->type(ordered_hash => [key => $_, value => $value->{$_}]), 'item', '')} keys %$value;
  return [$name, {'xsi:type' => "$prefix:Map", %$attr}, [@items], $self->gen_id($value)];
}

sub as_xml {
  my $self = shift;
  my($value, $name, $type, $attr) = @_;
  return [$name, {'_xml' => 1}, $value];
}

sub typecast {
  my $self = shift;
  my($value, $name, $type, $attr) = @_;
  return if ref $value; # skip complex object, caller knows how to deal with it
  return if $self->autotype && !defined $type; # we don't know, autotype knows
  return [$name,
          {(defined $type && $type gt '' ? ('xsi:type' => $self->maptypetouri($type, 'simple type')) : ()), %$attr},
          $value
  ];
}

# ----------------------------------------------------------------------

sub fixattrs {
  my $self = shift;
  my $data = shift;
  my($name, $attr) = ($data->SOAP::Data::name, {%{$data->SOAP::Data::attr}});
  my($xmlns, $prefix) = ($data->uri, $data->prefix);
  return ($name, $attr) unless defined($xmlns) || defined($prefix);
  $name ||= gen_name; # local name
  $prefix = gen_ns if !defined $prefix && $xmlns gt '';
  $prefix = '' if defined $xmlns  && $xmlns eq '' || 
                  defined $prefix && $prefix eq '';

  $attr->{join ':', xmlns => $prefix || ()} = $xmlns if defined $xmlns; 
  $name = join ':', $prefix, $name                   if $prefix;

  return ($name, $attr);
}

sub toqname {
  my $self = shift;
  my $long = shift;

  return $long unless $long =~ /^\{(.*)\}(.+)$/;
  return qualify $self->namespaces->{$1} ||= gen_ns, $2;
}

sub attrstoqname {
  my $self = shift;
  my $attrs = shift;

  return {
    map { /^\{(.*)\}(.+)$/ 
      ? ($self->toqname($_) => $2 eq 'type' || $2 eq 'arrayType' ? $self->toqname($attrs->{$_}) : $attrs->{$_})
      : ($_ => $attrs->{$_})
   } keys %$attrs
  };
}

sub tag {
  my $self = shift;
  my($tag, $attrs, @values) = @_;
  my $value = join '', @values;
  my $level = $self->level;
  my $indent = $self->readable ? "\n" . ' ' x (($level-1)*2) : '';
  # check for special attribute
  return "$indent$value" if exists $attrs->{_xml} && delete $attrs->{_xml}; 
  die "Element '$tag' can't be allowed in valid XML message. Died\n"
    if $tag !~ /^(?![xX][mM][lL])$SOAP::Constants::NSMASK$/o;

  my $prolog = '';
  if ($level == 1) {
    my $namespaces = $self->namespaces;
    foreach (keys %$namespaces) { $attrs->{qualify(xmlns => $namespaces->{$_})} = $_ }
    $prolog = qq!<?xml version="1.0" encoding="@{[$self->encoding]}"?>!
      if defined $self->encoding;
  }

  my $tagattrs = join(' ', '', map { sprintf '%s="%s"', $_, SOAP::Utils::encode_attribute($attrs->{$_}) } 
                              grep { $_ && defined $attrs->{$_} && ($_ ne 'xsi:type' || $attrs->{$_} ne '')
                                   } keys %$attrs);
  $value gt '' 
    ? sprintf("$prolog$indent<%s%s$indent>%s</%s>", $tag, $tagattrs, $value, $tag) 
    : sprintf("$prolog$indent<%s%s/>", $tag, $tagattrs);
}

sub xmlize {
  my $self = shift;
  my($name, $attrs, $values, $id) = @{+shift}; $attrs ||= {};

  local $self->{_level} = $self->{_level} + 1;
  return $self->tag($name, $attrs) unless defined $values;
  return $self->tag($name, $attrs, $values) unless UNIVERSAL::isa($values => 'ARRAY');
  return $self->tag($name, {%$attrs, href => '#' . $self->multiref_anchor($id)}) if $self->is_href($id, delete($attrs->{_id}));
  return $self->tag($name, {%$attrs, id => $self->multiref_anchor($id)}, map {$self->xmlize($_)} @$values); 
}

sub uriformethod {
  my $self = shift;

  my $method_is_data = ref $_[0] && UNIVERSAL::isa($_[0] => 'SOAP::Data');

  # drop prefrix from method that could be string or SOAP::Data object
  my($prefix, $method) = $method_is_data 
    ? ($_[0]->prefix, $_[0]->name)
    : SOAP::Utils::splitqname($_[0]);

  my $attr = {reverse %{$self->namespaces}};
  # try to define namespace that could be stored as
  #   a) method is SOAP::Data 
  #        ? attribute in method's element as xmlns= or xmlns:${prefix}=
  #        : uri
  #   b) attribute in Envelope element as xmlns= or xmlns:${prefix}=
  #   c) no prefix or prefix equal serializer->envprefix
  #        ? '', but see coment below
  #        : die with error message
  my $uri = $method_is_data 
    ? ref $_[0]->attr && ($_[0]->attr->{$prefix ? "xmlns:$prefix" : 'xmlns'} || $_[0]->uri)
    : $self->uri;

  defined $uri or $uri = $attr->{$prefix || ''};

  defined $uri or $uri = !$prefix || $prefix eq $self->envprefix 
    # still in doubts what should namespace be in this case 
    # but will keep it like this for now and be compatible with our server
    ? ( $method_is_data && $^W && warn("URI is not provided as an attribute for method ($method)\n"),
        ''
      )
    : die "Can't find namespace for method ($prefix:$method)\n";

  return ($uri, $method);
}

sub serialize { SOAP::Trace::trace('()');
  my $self = shift->new;
  @_ == 1 or Carp::croak "serialize() method accepts one parameter";

  $self->seen({}); # reinitialize multiref table
  my($encoded) = $self->encode_object($_[0]);

  # now encode multirefs if any
  #                 v -------------- subelements of Envelope
  push(@{$encoded->[2]}, $self->encode_multirefs) if ref $encoded->[2];
  return $self->xmlize($encoded);
}

sub envelope { SOAP::Trace::trace('()');
  my $self = shift->new;
  my $type = shift;

  my(@parameters, @header);
  for (@_) { 
    defined $_ && ref $_ && UNIVERSAL::isa($_ => 'SOAP::Header') 
      ? push(@header, $_) : push(@parameters, $_);
  }
  my $header = @header ? SOAP::Data->set_value(@header) : undef;
  my($body,$parameters);
  if ($type eq 'method' || $type eq 'response') {
    SOAP::Trace::method(@parameters);
    my $method = shift(@parameters) or die "Unspecified method for SOAP call\n";
    $parameters = @parameters ? SOAP::Data->set_value(@parameters) : undef;
    $body = UNIVERSAL::isa($method => 'SOAP::Data') 
      ? $method : SOAP::Data->name($method)->uri($self->uri);
    $body->set_value($parameters ? \$parameters : ());
  } elsif ($type eq 'fault') {
    SOAP::Trace::fault(@parameters);
    $body = SOAP::Data
      -> name(qualify($self->envprefix => 'Fault'))
    # commented on 2001/03/28 because of failing in ApacheSOAP
    # need to find out more about it