lite.pm

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

    # -> attr({'xmlns' => ''})
      -> value(\SOAP::Data->set_value(
        SOAP::Data->name(faultcode => qualify($self->envprefix => $parameters[0])),
        SOAP::Data->name(faultstring => $parameters[1]),
        defined($parameters[2]) ? SOAP::Data->name(detail => do{my $detail = $parameters[2]; ref $detail ? \$detail : $detail}) : (),
        defined($parameters[3]) ? SOAP::Data->name(faultactor => $parameters[3]) : (),
      ));
  } elsif ($type eq 'freeform') {
    SOAP::Trace::freeform(@parameters);
    $body = SOAP::Data->set_value(@parameters);
  } else {
    die "Wrong type of envelope ($type) for SOAP call\n";
  }

  $self->seen({}); # reinitialize multiref table
  my($encoded) = $self->encode_object(
    SOAP::Data->name(qualify($self->envprefix => 'Envelope') => \SOAP::Data->value(
      ($header ? SOAP::Data->name(qualify($self->envprefix => 'Header') => \$header) : ()),
      SOAP::Data->name(qualify($self->envprefix => 'Body')   => \$body)
    ))->attr($self->attr)
  );
  $self->signature($parameters->signature) if ref $parameters;

  # IMHO multirefs should be encoded after Body, but only some
  # toolkits understand this encoding, so we'll keep them for now (04/15/2001)
  # as the last element inside the Body 
  #                 v -------------- subelements of Envelope
  #                      vv -------- last of them (Body)
  #                            v --- subelements
  push(@{$encoded->[2]->[-1]->[2]}, $self->encode_multirefs) if ref $encoded->[2]->[-1]->[2];
  return $self->xmlize($encoded);
}

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

package SOAP::Parser;

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

sub xmlparser {
  my $self = shift;
  return eval { $SOAP::Constants::DO_NOT_USE_XML_PARSER ? undef : do {require XML::Parser; XML::Parser->new} } || 
         eval { require XML::Parser::Lite; XML::Parser::Lite->new } ||
         die "XML::Parser is not @{[$SOAP::Constants::DO_NOT_USE_XML_PARSER ? 'used' : 'available']} and ", $@;
}

sub parser {
  my $self = shift->new;
  @_ ? ($self->{'_parser'} = shift, return $self) : return ($self->{'_parser'} ||= $self->xmlparser);
}

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

  return $self if ref $self;

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

  return bless {_parser => shift} => $class;
}

sub decode { SOAP::Trace::trace('()');
  my $self = shift;

  $self->parser->setHandlers(
    Final => sub { shift; $self->final(@_) },
    Start => sub { shift; $self->start(@_) },
    End   => sub { shift; $self->end(@_)   },
    Char  => sub { shift; $self->char(@_)  },
  );
  $self->parser->parse($_[0]);
}

sub final { 
  my $self = shift; 

  # clean handlers, otherwise SOAP::Parser won't be deleted: 
  # it refers to XML::Parser which refers to subs from SOAP::Parser
  # Thanks to Ryan Adams <[e-mail]>
  # and Craig Johnston <[e-mail]>
  # checked by number of tests in t/02-payload.t

  undef $self->{_values};
  $self->parser->setHandlers(
    Final => undef, Start => undef, End   => undef, Char  => undef,
  );
  $self->{_done};
}

sub start { push @{shift->{_values}}, [shift, {@_}] }

sub char { shift->{_values}->[-1]->[3] .= shift }

sub end { 
  my $self = shift; 
  my $done = pop @{$self->{_values}};
  $done->[2] = defined $done->[3] ? $done->[3] : '' unless ref $done->[2];
  undef $done->[3]; 
  @{$self->{_values}} ? (push @{$self->{_values}->[-1]->[2]}, $done)
                      : ($self->{_done} = $done);
}

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

package SOAP::MIMEParser;

use vars qw(@ISA);

@ISA = qw(MIME::Parser);

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

sub new { local $^W; require MIME::Parser; Exporter::require_version('MIME::Parser' => 5.220); 
  my $self = shift;

  unless (ref $self) {
    my $class = ref($self) || $self;
    $self = $class->SUPER::new();
    unshift(@_, output_to_core => 'ALL', tmp_to_core => 1, ignore_errors => 1);
    SOAP::Trace::objects('()');
  }

  while (@_) { my $method = shift; $self->$method(shift) if $self->can($method) }

  return $self;
}

sub get_multipart_id { (shift || '') =~ /^<(.+)>$/; $1 || '' }

sub decode { 
  my $self = shift;

  my $entity = eval { $self->parse_data(shift) } or die "Something wrong with MIME message: @{[$@ || $self->last_error]}\n";

  my @result = 
    $entity->head->mime_type eq 'multipart/form-data' ? $self->decode_form_data($entity) :
    $entity->head->mime_type eq 'multipart/related' ? $self->decode_related($entity) :
    $entity->head->mime_type eq 'text/xml' ? () :
    die "Can't handle MIME messsage with specified type (@{[$entity->head->mime_type]})\n";

  @result ? @result 
          : $entity->bodyhandle->as_string ? [undef, '', undef, $entity->bodyhandle->as_string]
                                           : die "No content in MIME message\n";
}

sub decode_form_data { 
  my($self, $entity) = @_;

  my @result;
  foreach my $part ($entity->parts) {
    my $name = $part->head->mime_attr('content-disposition.name');
    my $type = $part->head->mime_type || '';

    $name eq 'payload' 
      ? unshift(@result, [$name, '', $type, $part->bodyhandle->as_string])
      : push(@result, [$name, '', $type, $part->bodyhandle->as_string]);
  }
  @result;
}

sub decode_related { 
  my($self, $entity) = @_;
  my $start = get_multipart_id($entity->head->mime_attr('content-type.start'));
  my $location = $entity->head->mime_attr('content-location') || 'thismessage:/';

  my @result;
  foreach my $part ($entity->parts) {
    my $pid = get_multipart_id($part->head->get('content-id',0));
    my $plocation = $part->head->get('content-location',0) || '';
    my $type = $part->head->mime_type || '';

    $start && $pid eq $start 
      ? unshift(@result, [$start, $location, $type, $part->bodyhandle->as_string])
      : push(@result, [$pid, $plocation, $type, $part->bodyhandle->as_string]);
  }
  die "Can't find 'start' parameter in multipart MIME message\n"
    if @result > 1 && !$start;
  @result;
}

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

package SOAP::SOM;

use Carp ();

sub BEGIN {
  no strict 'refs';
  my %path = (
    root        => '/',
    envelope    => '/Envelope',
    body        => '/Envelope/Body',
    header      => '/Envelope/Header',
    headers     => '/Envelope/Header/[>0]',
    fault       => '/Envelope/Body/Fault',
    faultcode   => '/Envelope/Body/Fault/faultcode',
    faultstring => '/Envelope/Body/Fault/faultstring',
    faultactor  => '/Envelope/Body/Fault/faultactor',
    faultdetail => '/Envelope/Body/Fault/detail',
  );
  for my $method (keys %path) {
    *$method = sub { 
      my $self = shift;
      ref $self or return $path{$method};
      Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_;
      return $self->valueof($path{$method});
    };
  }
  my %results = (
    method    => '/Envelope/Body/[1]',
    result    => '/Envelope/Body/[1]/[1]',
    freeform  => '/Envelope/Body/[>0]',
    paramsin  => '/Envelope/Body/[1]/[>0]',
    paramsall => '/Envelope/Body/[1]/[>0]',
    paramsout => '/Envelope/Body/[1]/[>1]',
  );
  for my $method (keys %results) {
    *$method = sub { 
      my $self = shift;
      ref $self or return $results{$method};
      Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_;
      defined $self->fault ? return : return $self->valueof($results{$method});
    };
  }

  for my $method (qw(o_child o_value o_lname o_lattr o_qname)) { # import from SOAP::Utils
    *$method = \&{'SOAP::Utils::'.$method};
  }
}

# use object in boolean context return true/false on last match
# Ex.: $som->match('//Fault') ? 'SOAP call failed' : 'success';
use overload fallback => 1, 'bool'  => sub { @{shift->{_current}} > 0 };

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

sub new { 
  my $self = shift;
  my $class = ref($self) || $self;
  my $content = shift;
  SOAP::Trace::objects('()');
  return bless { _content => $content, _current => [$content] } => $class;
}

sub current {
  my $self = shift;
  $self->{_current} = [@_], return $self if @_;
  return wantarray ? @{$self->{_current}} : $self->{_current}->[0];
}

sub valueof {
  my $self = shift;
  local $self->{_current} = $self->{_current}; 
  $self->match(shift) if @_;
  return wantarray ? map {o_value($_)} @{$self->{_current}} 
                   : @{$self->{_current}} ? o_value($self->{_current}->[0]) : undef;
}

sub headerof { # SOAP::Header is the same as SOAP::Data, so just rebless it
  wantarray 
    ? map { bless $_ => 'SOAP::Header' } shift->dataof(@_) 
    : do { # header returned by ->dataof can be undef in scalar context
        my $header = shift->dataof(@_); 
        ref $header ? bless($header => 'SOAP::Header') : undef;
      };
}

sub dataof {
  my $self = shift;
  local $self->{_current} = $self->{_current}; 
  $self->match(shift) if @_;
  return wantarray ? map {$self->_as_data($_)} @{$self->{_current}} 
                   : @{$self->{_current}} ? $self->_as_data($self->{_current}->[0]) : undef;
}

sub namespaceuriof {
  my $self = shift;
  local $self->{_current} = $self->{_current}; 
  $self->match(shift) if @_;
  return wantarray ? map {(SOAP::Utils::splitlongname(o_lname($_)))[0]} @{$self->{_current}} 
                   : @{$self->{_current}} ? (SOAP::Utils::splitlongname(o_lname($self->{_current}->[0])))[0] : undef;
}

sub _as_data {
  my $self = shift;
  my $pointer = shift;

  SOAP::Data
    -> new(prefix => '', name => o_qname($pointer), name => o_lname($pointer), attr => o_lattr($pointer))
    -> set_value(o_value($pointer));
}

sub match { 
  my $self = shift;
  my $path = shift;
  $self->{_current} = [
    $path =~ s!^/!! || !@{$self->{_current}}
      ? $self->_traverse($self->{_content}, 1 => split '/' => $path)
      : map {$self->_traverse_tree(o_child($_), split '/' => $path)} @{$self->{_current}}
  ];
  return $self;
}

sub _traverse {
  my $self = shift;
  my($pointer, $itself, $path, @path) = @_;

  if ($path && substr($path, 0, 1) eq '{') {
    $path = join '/', $path, shift @path while @path && $path !~ /}/;
  }

  my($op, $num) = $path =~ /^\[(<=|<|>=|>|=|!=?)?(\d+)\]$/ if defined $path;

  return $pointer unless defined $path;

  $op = '==' unless $op; $op .= '=' if $op eq '=' || $op eq '!';
  my $numok = defined $num && eval "$itself $op $num";
  my $nameok = (o_lname($pointer) || '') =~ /(?:^|\})$path$/ if defined $path; # name can be with namespace

  my $anynode = $path eq '';
  unless ($anynode) {
    if (@path) {
      return if defined $num && !$numok || !defined $num && !$nameok;
    } else {
      return $pointer if defined $num && $numok || !defined $num && $nameok;
      return;
    }
  }

  my @walk;
  push @walk, $self->_traverse_tree([$pointer], @path) if $anynode;
  push @walk, $self->_traverse_tree(o_child($pointer), $anynode ? ($path, @path) : @path);
  return @walk;
}

sub _traverse_tree {
  my $self = shift;
  my($pointer, @path) = @_;

  # can be list of children or value itself. Traverse only children
  return unless ref $pointer eq 'ARRAY'; 

  my $itself = 1;

  grep {defined} 
    map {$self->_traverse($_, $itself++, @path)} 
      grep {!ref o_lattr($_) ||
            !exists o_lattr($_)->{"{$SOAP::Constants::NS_ENC}root"} || 
            o_lattr($_)->{"{$SOAP::Constants::NS_ENC}root"} ne '0'}
        @$pointer;
}

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

package SOAP::Deserializer;

use vars qw(@ISA);

@ISA = qw(SOAP::Cloneable);

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

sub BEGIN {
  no strict 'refs';
  for my $method (qw(ids hrefs parser base xmlschemas xmlschema)) {
    my $field = '_' . $method;
    *$method = sub {
      my $self = shift->new;
      @_ ? ($self->{$field} = shift, return $self) : return $self->{$field};
    }
  }
}

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

  SOAP::Trace::objects('()');
  return bless {
    _ids => {}, 
    _hrefs => {},
    _parser => SOAP::Parser->new,
    _xmlschemas => {
      $SOAP::Constants::NS_APS => 'SOAP::XMLSchemaApacheSOAP::Deserializer', 
      map { $_ => $SOAP::Constants::XML_SCHEMAS{$_} . '::Deserializer'
          } keys %SOAP::Constants::XML_SCHEMAS
    },
  } => $class;
}

sub mimeparser {
  my $field = '_mimeparser';
  my $self = shift->new;