lite.pm

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

  @_ ? ($self->{$field} = shift, return $self) 
     : return $self->{$field} ||= new SOAP::MIMEParser;
}

sub is_xml {
  $_[1] =~ /^\s*</ || $_[1] !~ /^[\w-]+:/;
}

sub baselocation { 
  my $self = shift;
  my $location = shift;
  if ($location) { 
    my $uri = URI->new($location); 
    # make absolute location if relative
    $location = $uri->abs($self->base)->as_string unless $uri->scheme;
  }
  $location;
}

sub mimedecode {
  my $self = shift->new;

  my $body;
  foreach ($self->mimeparser->decode($_[0])) {
    my($id, $location, $type, $value) = @$_;

    unless ($body) { # we are here for the first time, so it's a MAIN part
      $body = $self->parser->decode($value);
      $self->base($location); # store the base location
    } else {
      $location = $self->baselocation($location);
      my $part = $type eq 'text/xml' && !$SOAP::Constants::DO_NOT_PROCESS_XML_IN_MIME ? $self->parser->decode($value) : ['mimepart', {}, $value];
      $self->ids->{$id} = $part if $id;
      $self->ids->{$location} = $part if $location;
    }
  }
  return $body;
}

sub decode {
  my $self = shift->new;
  return $self->is_xml($_[0]) 
    ? $self->parser->decode($_[0]) 
    : $self->mimedecode($_[0]);
}

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

  # initialize 
  $self->hrefs({}); 
  $self->ids({}); 

  # TBD: find better way to signal parsing errors
  my $parsed = $self->decode($_[0]); # TBD: die on possible errors in Parser?

  # if there are some IDs (from mime processing), then process others
  # otherwise delay till we first meet IDs
  if (keys %{$self->ids()}) {$self->traverse_ids($parsed)} else {$self->ids($parsed)}

  $self->decode_object($parsed);
  return SOAP::SOM->new($parsed);
}

sub traverse_ids {
  my $self = shift;
  my $ref = shift;
  my($undef, $attrs, $children) = @$ref;
  #  ^^^^^^ to fix nasty error on Mac platform (Carl K. Cunningham)

  $self->ids->{$attrs->{id}} = $ref if exists $attrs->{id};
  return unless ref $children;
  for (@$children) {$self->traverse_ids($_)};
}

sub decode_object {
  my $self = shift;              
  my $ref = shift;
  my($name, $attrs, $children, $value) = @$ref;

  $ref->[6] = $attrs = {%$attrs}; # make a copy for long attributes

  use vars qw(%uris);
  local %uris = (%uris, map { 
      do { (my $ns = $_) =~ s/^xmlns:?//; $ns } => delete $attrs->{$_} 
    } grep {/^xmlns(:|$)/} keys %$attrs);

  foreach (keys %$attrs) {
    next unless m/^($SOAP::Constants::NSMASK?):($SOAP::Constants::NSMASK)$/;

    $1 =~ /^[xX][mM][lL]/ ||
      $uris{$1} && 
        do { 
          $attrs->{SOAP::Utils::longname($uris{$1}, $2)} = do { 
            my $value = delete $attrs->{$_};
            $2 ne 'type' && $2 ne 'arrayType'
              ? $value 
              : SOAP::Utils::longname($value =~ m/^($SOAP::Constants::NSMASK?):(${SOAP::Constants::NSMASK}(?:\[[\d,]*\])*)/ 
                  ? ($uris{$1} || die("Unresolved prefix '$1' for attribute value '$value'\n"), $2)
                  : ($uris{''} || die("Unspecified namespace for type '$value'\n"), $value)
                );
          };
          1;
        } || 
      die "Unresolved prefix '$1' for attribute '$_'\n";
  }

  # and now check the element
  my $ns = ($name =~ s/^($SOAP::Constants::NSMASK?):// ? $1 : '');
  $ref->[5] = SOAP::Utils::longname(
    $ns ? ($uris{$ns} || die "Unresolved prefix '$ns' for element '$name'\n")
        : (defined $uris{''} ? $uris{''} : undef),
    $name
  );

  ($children, $value) = (undef, $children) unless ref $children;

  return $name => ($ref->[4] = $self->decode_value(
    [$ref->[5], $attrs, $children, $value]
  ));
}

sub decode_value {
  my $self = shift;
  my $ref = shift;
  my($name, $attrs, $children, $value) = @$ref;

  # check SOAP version if applicable
  use vars '$level'; local $level = $level || 0;
  if (++$level == 1) {
    my($namespace, $envelope) = SOAP::Utils::splitlongname($name);
    SOAP::Lite->soapversion($namespace) if $envelope eq 'Envelope' && $namespace;
  }

  # check encodingStyle
  # future versions may bind deserializer to encodingStyle
  my $encodingStyle = $attrs->{"{$SOAP::Constants::NS_ENV}encodingStyle"};
  die "Unrecognized/unsupported value of encodingStyle attribute '$encodingStyle'\n"
    if defined $encodingStyle &&
       length($encodingStyle) != 0 && # encodingStyle=""
       $encodingStyle !~ /(?:^|\b)$SOAP::Constants::NS_ENC/;
                        # ^^^^^^^^ \b causing problems (!?) on some systems 
                        # as reported by David Dyck <[e-mail]>
                        # so use (?:^|\b) instead

  use vars '$arraytype'; # type of Array element specified on Array itself 
  # either specified with xsi:type, or <enc:name/> or array element 
  my($type) = grep {defined} 
                map($attrs->{$_}, sort grep {/^\{$SOAP::Constants::NS_XSI_ALL\}type$/o} keys %$attrs), 
                $name =~ /^\{$SOAP::Constants::NS_ENC\}/ ? $name : $arraytype;
  local $arraytype; # it's used only for one level, we don't need it anymore

  # $name is not used here since type should be encoded as type, not as name
  my($schema, $class) = SOAP::Utils::splitlongname($type) if $type;

  my $schemaclass = $schema && $self->xmlschemas->{$schema}
                            || $self;
  # store schema that is used in parsed message 
  $self->xmlschema($schema) if $schema && $schema =~ /XMLSchema/;

  # don't use class/type if anyType/ur-type is specified on wire
  undef $class if $schemaclass->can('anyTypeValue') && $schemaclass->anyTypeValue eq $class;

  my $method = 'as_' . ($class || '-'); # dummy type if not defined
  $class =~ s/__|\./::/g if $class;

  my $id = $attrs->{id};

  if (defined $id && exists $self->hrefs->{$id}) {
    return $self->hrefs->{$id};
  } elsif (exists $attrs->{href}) {
    (my $id = delete $attrs->{href}) =~ s/^(#|cid:)?//;
    # convert to absolute if not internal '#' or 'cid:'
    $id = $self->baselocation($id) unless $1;
    return $self->hrefs->{$id} if exists $self->hrefs->{$id};
    my $ids = $self->ids;
    # first time optimization. we don't traverse IDs unless asked for it
    if (ref $ids ne 'HASH') { $self->ids({}); $self->traverse_ids($ids); $ids = $self->ids }
    if (exists $ids->{$id}) {
      my $obj = ($self->decode_object(delete $ids->{$id}))[1];
      return $self->hrefs->{$id} = $obj; 
    } else {
      die "Unresolved (wrong?) href ($id) in element '$name'\n";
    }
  }

  return undef if grep {
    /^$SOAP::Constants::NS_XSI_NILS$/ && 
    $self->xmlschemas->{$1 || $2}->as_undef($attrs->{$_})
  } keys %$attrs;

  # try to handle with typecasting
  my $res = $self->typecast($value, $name, $attrs, $children, $type);
  return $res if defined $res;

  # ok, continue with others
  if (exists $attrs->{"{$SOAP::Constants::NS_ENC}arrayType"}) {
    my $res = [];
    $self->hrefs->{$id} = $res if defined $id;

    # check for arrayType which could be [1], [,2][5] or [] 
    # [,][1] will NOT be allowed right now (multidimensional sparse array)
    my($type, $multisize) = $attrs->{"{$SOAP::Constants::NS_ENC}arrayType"} 
      =~ /^(.+)\[(\d*(?:,\d+)*)\](?:\[(?:\d+(?:,\d+)*)\])*$/
      or die qq!Unrecognized/unsupported format of arrayType attribute '@{[$attrs->{"{$SOAP::Constants::NS_ENC}arrayType"}]}'\n!;

    my @dimensions = map { $_ || undef } split /,/, $multisize;
    my $size = 1; foreach (@dimensions) { $size *= $_ || 0 }

    local $arraytype = $type;

    # multidimensional
    if ($multisize =~ /,/) { 
      @$res = splitarray(
        [@dimensions], 
        [map { scalar(($self->decode_object($_))[1]) } @{$children || []}]
      );

    # normal
    } else {
      @$res = map { scalar(($self->decode_object($_))[1]) } @{$children || []};
    }

    # sparse (position)
    if (ref $children && exists SOAP::Utils::o_lattr($children->[0])->{"{$SOAP::Constants::NS_ENC}position"}) {
      my @new;
      for (my $pos = 0; $pos < @$children; $pos++) {
        # TBD implement position in multidimensional array
        my($position) = SOAP::Utils::o_lattr($children->[$pos])->{"{$SOAP::Constants::NS_ENC}position"} =~ /^\[(\d+)\]$/
          or die "Position must be specified for all elements of sparse array\n";
        $new[$position] = $res->[$pos];
      }
      @$res = @new;
    }

    # partially transmitted (offset)
    # TBD implement offset in multidimensional array
    my($offset) = $attrs->{"{$SOAP::Constants::NS_ENC}offset"} =~ /^\[(\d+)\]$/
      if exists $attrs->{"{$SOAP::Constants::NS_ENC}offset"};
    unshift(@$res, (undef) x $offset) if $offset;

    die "Too many elements in array. @{[scalar@$res]} instead of claimed $multisize ($size)\n"
      if $multisize && $size < @$res;

    # extend the array if number of elements is specified
    $#$res = $dimensions[0]-1 if defined $dimensions[0] && @$res < $dimensions[0];

    return defined $class && $class ne 'Array' ? bless($res => $class) : $res;

  } elsif ($name =~ /^\{$SOAP::Constants::NS_ENC\}Struct$/ || !$schemaclass->can($method) && (ref $children || defined $class && $value =~ /^\s*$/)) {
    my $res = {};
    $self->hrefs->{$id} = $res if defined $id;
    %$res = map {$self->decode_object($_)} @{$children || []};
    return defined $class && $class ne 'SOAPStruct' ? bless($res => $class) : $res;

  } else {
    my $res;
    if ($schemaclass->can($method)) {
      $method = "$schemaclass\::$method" unless ref $schemaclass; 
      $res = $self->$method($value, $name, $attrs, $children, $type);
    } else {
      $res = $self->typecast($value, $name, $attrs, $children, $type);
      $res = $class ? die "Unrecognized type '$type'\n" : $value
        unless defined $res;
    }
    $self->hrefs->{$id} = $res if defined $id;
    return $res;
  }
}

sub splitarray {
  my @sizes = @{+shift};
  my $size = shift @sizes;
  my $array = shift;

  return splice(@$array, 0, $size) unless @sizes;
  my @array = ();
  push @array, [splitarray([@sizes], $array)] while @$array && (!defined $size || $size--);
  return @array;
}

sub typecast { } # typecast is called for both objects AND scalar types
                 # check ref of the second parameter (first is the object)
                 # return undef if you don't want to handle it

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

package SOAP::Client;

sub BEGIN {
  no strict 'refs';
  for my $method (qw(endpoint code message is_success status options)) {
    my $field = '_' . $method;
    *$method = sub {
      my $self = shift->new;
      @_ ? ($self->{$field} = shift, return $self) : return $self->{$field};
    }
  }
}

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

package SOAP::Server::Object;

sub gen_id; *gen_id = \&SOAP::Serializer::gen_id;

my %alive;
my %objects;

sub objects_by_reference { 
  shift; 
  while (@_) { @alive{shift()} = ref $_[0] ? shift : sub { $_[1]-$_[$_[5] ? 5 : 4] > 600 } } 
  keys %alive;
}

sub reference {
  my $self = shift;
  my $stamp = time;
  my $object = shift; 
  my $id = $stamp . $self->gen_id($object);

  # this is code for garbage collection
  my $time = time;
  my $type = ref $object;
  my @objects = grep { $objects{$_}->[1] eq $type } keys %objects;
  for (grep { $alive{$type}->(scalar @objects, $time, @{$objects{$_}}) } @objects) { 
    delete $objects{$_}; 
  } 

  $objects{$id} = [$object, $type, $stamp];
  bless { id => $id } => ref $object;
}

sub references {
  my $self = shift;
  return @_ unless %alive; # small optimization
  map { ref($_) && exists $alive{ref $_} ? $self->reference($_) : $_ } @_;
}

sub object {
  my $self = shift;
  my $class = ref($self) || $self;
  my $object = shift;
  return $object unless ref($object) && $alive{ref $object} && exists $object->{id};
  my $reference = $objects{$object->{id}};
  die "Object with specified id couldn't be found\n" unless ref $reference->[0];
  $reference->[3] = time; # last access time
  return $reference->[0]; # reference to actual object
}

sub objects {
  my $self = shift; 
  return @_ unless %alive; # small optimization
  map { ref($_) && exists $alive{ref $_} && exists $_->{id} ? $self->object($_) : $_ } @_;
}

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

package SOAP::Server::Parameters;

sub byNameOrOrder {
  unless (UNIVERSAL::isa($_[-1] => 'SOAP::SOM')) {
    warn "Last parameter is expected to be envelope\n" if $^W;
    pop;
    return @_;
  }
  my $params = pop->method;
  my @mandatory = ref $_[0] eq 'ARRAY' ? @{shift()} : die "list of parameters expected as the first parameter for byName";
  my $byname = 0; 
  my @res = map { $byname += exists $params->{$_}; $params->{$_} } @mandatory;
  return $byname ? @res : @_;
}

sub byName {
  unless (UNIVERSAL::isa($_[-1] => 'SOAP::SOM')) {
    warn "Last parameter is expected to be envelope\n" if $^W;
    pop;
    return @_;
  }
  return @{pop->method}{ref $_[0] eq 'ARRAY' ? @{shift()} : die "list of parameters expected as the first parameter for byName"};
}

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

package SOAP::Server;

use Carp ();

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

sub new { 
  my $self = shift;

  unless (ref $self) {
    my $class = ref($self) ||