lite.pm

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

# ======================================================================
#
# Copyright (C) 2000-2001 Paul Kulchenko ([e-mail])
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#                      
# $Id: Lite.pm,v 1.44 2001/10/18 16:18:56 paulk Exp $
#
# ======================================================================

package SOAP::Lite;

use 5.004;
use strict;
use vars qw($VERSION);
$VERSION = eval sprintf("%d.%s", q$Name: release-0_52-public $ =~ /-(\d+)_([\d_]+)/)
  or warn "warning: unspecified/non-released version of ", __PACKAGE__, "\n";

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

package SOAP::XMLSchemaSOAP1_1::Deserializer;

sub anyTypeValue { 'ur-type' }

sub as_boolean { shift; my $value = shift; $value eq '1' || $value eq 'true' ? 1 : $value eq '0' || $value eq 'false' ? 0 : die "Wrong boolean value '$value'\n" }
sub as_base64 { shift; require MIME::Base64; MIME::Base64::decode_base64(shift) }
sub as_ur_type { $_[1] }

BEGIN {
  no strict 'refs';
  for my $method (qw(
    string float double decimal timeDuration recurringDuration uriReference
    integer nonPositiveInteger negativeInteger long int short byte
    nonNegativeInteger unsignedLong unsignedInt unsignedShort unsignedByte
    positiveInteger timeInstant time timePeriod date month year century 
    recurringDate recurringDay language
  )) { my $name = 'as_' . $method; *$name = sub { $_[1] } }
}

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

package SOAP::XMLSchemaSOAP1_2::Deserializer;

sub anyTypeValue { 'anyType' }

sub as_boolean; *as_boolean = \&SOAP::XMLSchemaSOAP1_1::Deserializer::as_boolean;
sub as_base64 { shift; require MIME::Base64; MIME::Base64::decode_base64(shift) }
sub as_anyType { $_[1] }

BEGIN {
  no strict 'refs';
  for my $method (qw(
    string float double decimal dateTime timePeriod gMonth gYearMonth gYear century 
    gMonthDay gDay duration recurringDuration anyURI
    language integer nonPositiveInteger negativeInteger long int short byte
    nonNegativeInteger unsignedLong unsignedInt unsignedShort unsignedByte
    positiveInteger date time dateTime
  )) { my $name = 'as_' . $method; *$name = sub { $_[1] } }
}

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

package SOAP::XMLSchemaApacheSOAP::Deserializer;

sub as_map { 
  my $self = shift;
  +{ map { my $hash = ($self->decode_object($_))[1]; ($hash->{key} => $hash->{value}) } @{$_[3] || []} };
}
sub as_Map; *as_Map = \&as_map;

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

package SOAP::XMLSchema::Serializer;

use vars qw(@ISA);

sub xmlschemaclass {
  my $self = shift;
  return $ISA[0] unless @_;
  @ISA = (shift);
  return $self;
}

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

package SOAP::XMLSchema1999::Serializer;

use vars qw(@EXPORT $AUTOLOAD);

sub AUTOLOAD {
  local($1,$2);
  my($package, $method) = $AUTOLOAD =~ m/(?:(.+)::)([^:]+)$/;
  return if $method eq 'DESTROY';

  no strict 'refs';
  die "Type '$method' can't be found in a schema class '$package'\n"
    unless $method =~ s/^as_// && grep {$_ eq $method} @{"$package\::EXPORT"};

  $method =~ s/_/-/; # fix ur-type

  *$AUTOLOAD = sub { 
    my $self = shift;
    my($value, $name, $type, $attr) = @_;
    return [$name, {'xsi:type' => "xsd:$method", %$attr}, $value];
  };
  goto &$AUTOLOAD;
}

BEGIN {
  @EXPORT = qw(ur_type
    float double decimal timeDuration recurringDuration uriReference
    integer nonPositiveInteger negativeInteger long int short byte
    nonNegativeInteger unsignedLong unsignedInt unsignedShort unsignedByte
    positiveInteger timeInstant time timePeriod date month year century 
    recurringDate recurringDay language
    base64 hex string boolean
  );
  # predeclare subs, so ->can check will be positive 
  foreach (@EXPORT) { eval "sub as_$_" } 
}

sub nilValue { 'null' }
sub anyTypeValue { 'ur-type' }

sub as_base64 {
  my $self = shift;
  my($value, $name, $type, $attr) = @_;
  require MIME::Base64;
  return [$name, {'xsi:type' => SOAP::Utils::qualify($self->encprefix => 'base64'), %$attr}, MIME::Base64::encode_base64($value,'')];
}

sub as_hex { 
  my $self = shift;
  my($value, $name, $type, $attr) = @_;
  return [$name, {'xsi:type' => 'xsd:hex', %$attr}, join '', map {uc sprintf "%02x", ord} split '', $value];
}

sub as_string {
  my $self = shift;
  my($value, $name, $type, $attr) = @_;
  die "String value expected instead of @{[ref $value]} reference\n" if ref $value;
  return [$name, {'xsi:type' => 'xsd:string', %$attr}, SOAP::Utils::encode_data($value)];
}

sub as_undef { $_[1] ? '1' : '0' }

sub as_boolean {
  my $self = shift;
  my($value, $name, $type, $attr) = @_;
  return [$name, {'xsi:type' => 'xsd:boolean', %$attr}, $value ? '1' : '0'];
}

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

package SOAP::XMLSchema1999::Deserializer;

sub anyTypeValue { 'ur-type' }

sub as_string; *as_string = \&SOAP::XMLSchemaSOAP1_1::Deserializer::as_string;
sub as_boolean; *as_boolean = \&SOAP::XMLSchemaSOAP1_1::Deserializer::as_boolean;
sub as_hex { shift; my $value = shift; $value =~ s/([a-zA-Z0-9]{2})/chr oct '0x'.$1/ge; $value }
sub as_ur_type { $_[1] }
sub as_undef { shift; my $value = shift; $value eq '1' || $value eq 'true' ? 1 : $value eq '0' || $value eq 'false' ? 0 : die "Wrong null/nil value '$value'\n" }

BEGIN {
  no strict 'refs';
  for my $method (qw(
    float double decimal timeDuration recurringDuration uriReference
    integer nonPositiveInteger negativeInteger long int short byte
    nonNegativeInteger unsignedLong unsignedInt unsignedShort unsignedByte
    positiveInteger timeInstant time timePeriod date month year century 
    recurringDate recurringDay language
  )) { my $name = 'as_' . $method; *$name = sub { $_[1] } }
}

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

package SOAP::XMLSchema2001::Serializer;

use vars qw(@EXPORT);

# no more warnings about "used only once"
*AUTOLOAD if 0; 

*AUTOLOAD = \&SOAP::XMLSchema1999::Serializer::AUTOLOAD;

BEGIN {
  @EXPORT = qw(anyType anySimpleType
    float double decimal dateTime timePeriod gMonth gYearMonth gYear century 
    gMonthDay gDay duration recurringDuration anyURI
    language integer nonPositiveInteger negativeInteger long int short byte
    nonNegativeInteger unsignedLong unsignedInt unsignedShort unsignedByte
    positiveInteger date time
    string hex base64 boolean
  );
  # predeclare subs, so ->can check will be positive 
  foreach (@EXPORT) { eval "sub as_$_" } 
}

sub nilValue { 'nil' }
sub anyTypeValue { 'anyType' }

sub as_hexBinary { 
  my $self = shift;
  my($value, $name, $type, $attr) = @_;
  return [$name, {'xsi:type' => 'xsd:hexBinary', %$attr}, join '', map {uc sprintf "%02x", ord} split '', $value];
}

sub as_base64Binary {
  my $self = shift;
  my($value, $name, $type, $attr) = @_;
  require MIME::Base64;
  return [$name, {'xsi:type' => 'xsd:base64Binary', %$attr}, MIME::Base64::encode_base64($value,'')];
}

sub as_string; *as_string = \&SOAP::XMLSchema1999::Serializer::as_string;
sub as_hex; *as_hex = \&as_hexBinary;
sub as_base64; *as_base64 = \&as_base64Binary;
sub as_timeInstant; *as_timeInstant = \&as_dateTime;

sub as_undef { $_[1] ? 'true' : 'false' }

sub as_boolean {
  my $self = shift;
  my($value, $name, $type, $attr) = @_;
  return [$name, {'xsi:type' => 'xsd:boolean', %$attr}, $value ? 'true' : 'false'];
}

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

package SOAP::XMLSchema2001::Deserializer;

sub anyTypeValue { 'anyType' }

sub as_string; *as_string = \&SOAP::XMLSchema1999::Deserializer::as_string;
sub as_boolean; *as_boolean = \&SOAP::XMLSchemaSOAP1_2::Deserializer::as_boolean;
sub as_base64Binary; *as_base64Binary = \&SOAP::XMLSchemaSOAP1_2::Deserializer::as_base64;
sub as_hexBinary; *as_hexBinary = \&SOAP::XMLSchema1999::Deserializer::as_hex;
sub as_undef; *as_undef = \&SOAP::XMLSchema1999::Deserializer::as_undef;

BEGIN {
  no strict 'refs';
  for my $method (qw(
    anyType anySimpleType
    float double decimal dateTime timePeriod gMonth gYearMonth gYear century 
    gMonthDay gDay duration recurringDuration anyURI
    language integer nonPositiveInteger negativeInteger long int short byte
    nonNegativeInteger unsignedLong unsignedInt unsignedShort unsignedByte
    positiveInteger date time dateTime
  )) { my $name = 'as_' . $method; *$name = sub { $_[1] } }
}

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

package SOAP::Constants;

BEGIN {

  use vars qw($NSMASK $ELMASK);

  $NSMASK = '[a-zA-Z_:][\w.\-:]*'; 
  $ELMASK = '^(?![xX][mM][lL])[a-zA-Z_][\w.\-]*$';

  use vars qw($NEXT_ACTOR $NS_ENV $NS_ENC $NS_APS
              $FAULT_CLIENT $FAULT_SERVER $FAULT_VERSION_MISMATCH
              $HTTP_ON_FAULT_CODE $HTTP_ON_SUCCESS_CODE $FAULT_MUST_UNDERSTAND
              $NS_XSI_ALL $NS_XSI_NILS %XML_SCHEMAS $DEFAULT_XML_SCHEMA
              $SOAP_VERSION %SOAP_VERSIONS $WRONG_VERSION
              $NS_SL_HEADER $NS_SL_PERLTYPE $PREFIX_ENV $PREFIX_ENC
              $DO_NOT_USE_XML_PARSER $DO_NOT_CHECK_MUSTUNDERSTAND 
              $DO_NOT_USE_CHARSET $DO_NOT_PROCESS_XML_IN_MIME
              $DO_NOT_USE_LWP_LENGTH_HACK $DO_NOT_CHECK_CONTENT_TYPE
  );  

  $FAULT_CLIENT = 'Client';
  $FAULT_SERVER = 'Server';
  $FAULT_VERSION_MISMATCH = 'VersionMismatch';
  $FAULT_MUST_UNDERSTAND = 'MustUnderstand';
  
  $HTTP_ON_SUCCESS_CODE = 200; # OK
  $HTTP_ON_FAULT_CODE   = 500; # INTERNAL_SERVER_ERROR

  $WRONG_VERSION = 'Wrong SOAP version specified.';

  %SOAP_VERSIONS = (
    ($SOAP_VERSION = 1.1) => {
      NEXT_ACTOR => 'http://schemas.xmlsoap.org/soap/actor/next',
      NS_ENV => 'http://schemas.xmlsoap.org/soap/envelope/',
      NS_ENC => 'http://schemas.xmlsoap.org/soap/encoding/',
      DEFAULT_XML_SCHEMA => 'http://www.w3.org/1999/XMLSchema',
    },
    1.2 => {
      NEXT_ACTOR => 'http://www.w3.org/2001/06/soap-envelope/actor/next',
      NS_ENV => 'http://www.w3.org/2001/06/soap-envelope',
      NS_ENC => 'http://www.w3.org/2001/06/soap-encoding',
      DEFAULT_XML_SCHEMA => 'http://www.w3.org/2001/XMLSchema',
    },
  );

  # schema namespaces                                    
  %XML_SCHEMAS = (
    'http://www.w3.org/1999/XMLSchema' => 'SOAP::XMLSchema1999',
    'http://www.w3.org/2001/XMLSchema' => 'SOAP::XMLSchema2001',
    'http://schemas.xmlsoap.org/soap/encoding/' => 'SOAP::XMLSchemaSOAP1_1',
    'http://www.w3.org/2001/06/soap-encoding' => 'SOAP::XMLSchemaSOAP1_2',
  );
  
  $NS_XSI_ALL = join join('|', map {"$_-instance"} grep {/XMLSchema/} keys %XML_SCHEMAS),
                     '(?:', ')';
  $NS_XSI_NILS = join join('|', map { my $class = $XML_SCHEMAS{$_} . '::Serializer'; "\{($_)-instance\}" . $class->nilValue
                                    } grep {/XMLSchema/} keys %XML_SCHEMAS),
                      '(?:', ')';
  
  # ApacheSOAP namespaces
  $NS_APS = 'http://xml.apache.org/xml-soap';
  
  # SOAP::Lite namespace
  $NS_SL_HEADER = 'http://namespaces.soaplite.com/header';
  $NS_SL_PERLTYPE = 'http://namespaces.soaplite.com/perl';

  # default prefixes
  $PREFIX_ENV = 'SOAP-ENV';
  $PREFIX_ENC = 'SOAP-ENC';
  
  # others
  $DO_NOT_USE_XML_PARSER = 0;
  $DO_NOT_CHECK_MUSTUNDERSTAND = 0;
  $DO_NOT_USE_CHARSET = 0;
  $DO_NOT_PROCESS_XML_IN_MIME = 0;
  $DO_NOT_USE_LWP_LENGTH_HACK = 0;
  $DO_NOT_CHECK_CONTENT_TYPE = 0;
}
  
# ======================================================================

package SOAP::Utils;

sub qualify { $_[1] ? $_[1] =~ /:/ ? $_[1] : join(':', $_[0] || (), $_[1]) : defined $_[1] ? $_[0] : '' }
sub overqualify (&$) { for ($_[1]) { &{$_[0]}; s/^:|:$//g } }
sub disqualify {
  (my $qname = shift) =~ s/^($SOAP::Constants::NSMASK?)://;
  $qname;
}
sub splitqname { local($1,$2); $_[0] =~ /^(?:([^:]+):)?(.+)$/; return ($1,$2) }
sub longname { defined $_[0] ? sprintf('{%s}%s', $_[0], $_[1]) : $_[1] }
sub splitlongname { local($1,$2); $_[0] =~ /^(?:\{(.*)\})?(.+)$/; return ($1,$2) }

# Q: why only '&' and '<' are encoded, but not '>'?
# A: because it is not required according to XML spec.
#
# [http://www.w3.org/TR/REC-xml#syntax]
# The ampersand character (&) and the left angle bracket (<) may appear in 
# their literal form only when used as markup delimiters, or within a comment, 
# a processing instruction, or a CDATA section. If they are needed elsewhere, 
# they must be escaped using either numeric character references or the 
# strings "&amp;" and "&lt;" respectively. The right angle bracket (>) may be 
# represented using the string "&gt;", and must, for compatibility, be 
# escaped using "&gt;" or a character reference when it appears in the 
# string "]]>" in content, when that string is not marking the end of a 
# CDATA section.

my %encode_attribute = ('&' => '&amp;', '<' => '&lt;', '"' => '&quot;');
sub encode_attribute { (my $e = $_[0]) =~ s/([&<"])/$encode_attribute{$1}/g; $e }

my %encode_data = ('&' => '&amp;', '<' => '&lt;', "\xd" => '&#xd;');
sub encode_data { (my $e = $_[0]) =~ s/([&<\015])/$encode_data{$1}/g; $e =~ s/\]\]>/\]\]&gt;/g; $e }

# methods for internal tree (SOAP::Deserializer, SOAP::SOM and SOAP::Serializer)

sub o_qname { $_[0]->[0] }
sub o_attr  { $_[0]->[1] }
sub o_child { ref $_[0]->[2] ? $_[0]->[2] : undef }
sub o_chars { ref $_[0]->[2] ? undef : $_[0]->[2] }
            # $_[0]->[3] is not used. Serializer stores object ID there
sub o_value { $_[0]->[4] }
sub o_lname { $_[0]->[5] }
sub o_lattr { $_[0]->[6] }

# make bytelength that calculates length in bytes regardless of utf/byte settings
# either we can do 'use bytes' or length will count bytes already      
BEGIN { 
  sub bytelength; 
  eval ( eval('use bytes; 1') # 5.6.0 and later?
    ? 'sub bytelength { use bytes; length(@_ ? $_[0] : $_) }; 1'
    : 'sub bytelength { length(@_ ? $_[0] : $_) }; 1' 
  ) or die;
}

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

package SOAP::Cloneable;

sub clone {
  my $self = shift;
  return unless ref $self && UNIVERSAL::isa($self => __PACKAGE__);