File Coverage

blib/lib/RPC/XML.pm

Criterion	Covered	Total	%
statement	610	617	98.8
branch	137	144	95.1
condition	70	98	71.4
subroutine	106	106	100.0
pod	0	9	0.0
total	923	974	94.7

###############################################################################
#
# This file copyright (c) 2001-2014 Randy J. Ray, all rights reserved
#
# Copying and distribution are permitted under the terms of the Artistic
# License 2.0 (http://www.opensource.org/licenses/artistic-license-2.0.php) or
# the GNU LGPL (http://www.opensource.org/licenses/lgpl-2.1.php).
#
###############################################################################
#
#   Description:    This module provides the core XML <-> RPC conversion and
#                   structural management.
#
#   Functions:      This module contains many, many subclasses. Better to
#                   examine them individually.
#
#   Libraries:      RPC::XML::base64 uses MIME::Base64
#                   DateTime::Format::ISO8601 is used if available
#
#   Global Consts:  $VERSION
#
###############################################################################

package RPC::XML;

use 5.008008;
use strict;
use warnings;
use vars qw(@EXPORT_OK %EXPORT_TAGS $VERSION $ERROR
            %XMLMAP $XMLRE $ENCODING $FORCE_STRING_ENCODING $ALLOW_NIL
            $DATETIME_REGEXP $DATETIME_ISO8601_AVAILABLE);
use subs qw(time2iso8601 smart_encode);
use base 'Exporter';

use Module::Load;
use Scalar::Util qw(blessed reftype);

# The RPC_* convenience-encoders need prototypes:
## no critic (ProhibitSubroutinePrototypes)
# This module declares all the data-type packages:
## no critic (ProhibitMultiplePackages)
# The data-type package names trigger this one:
## no critic (Capitalization)

BEGIN
{
    # Default encoding:
    $ENCODING = 'us-ascii';

    # force strings?
    $FORCE_STRING_ENCODING = 0;

    # Allow the  extension?
    $ALLOW_NIL = 0;

    # Determine if the DateTime::Format::ISO8601 module is available for
    # RPC::XML::datetime_iso8601 to use:
    $DATETIME_ISO8601_AVAILABLE = eval { load DateTime::Format::ISO8601; 1; };
}

@EXPORT_OK = qw(time2iso8601 smart_encode
                RPC_BOOLEAN RPC_INT RPC_I4 RPC_I8 RPC_DOUBLE
                RPC_DATETIME_ISO8601 RPC_BASE64 RPC_STRING RPC_NIL
                $ENCODING $FORCE_STRING_ENCODING $ALLOW_NIL);
%EXPORT_TAGS = (types => [ qw(RPC_BOOLEAN RPC_INT RPC_I4 RPC_I8 RPC_DOUBLE
                              RPC_STRING RPC_DATETIME_ISO8601 RPC_BASE64
                              RPC_NIL) ],
                all   => [ @EXPORT_OK ]);

$VERSION = '1.60';
$VERSION = eval $VERSION; ## no critic (ProhibitStringyEval)

# Global error string
$ERROR = q{};

# These are used for stringifying XML-sensitive characters that may appear
# in struct keys:
%XMLMAP = (
    q{>} => '>',
    q{<} => '<',
    q{&} => '&',
    q{"} => '"',
    q{'} => ''',
    "\x0d" => '
'
);
$XMLRE = join q{} => keys %XMLMAP; $XMLRE = qr/([$XMLRE])/;

# The XMLRPC spec only allows for the incorrect iso8601 format
# without dashes, but dashes are part of the standard so we include
# them. Note that the actual RPC::XML::datetime_iso8601 class will strip
# them out if present.
my $date_re =
    qr{
          (\d{4})-?
          ([01]\d)-?
          ([0123]\d)
    }x;
my $time_re =
    qr{
          ([012]\d):
          ([0-5]\d):
          ([0-5]\d)([.,]\d+)?
          (Z|[-+]\d\d:\d\d)?
    }x;
$DATETIME_REGEXP = qr{^${date_re}T?${time_re}$};

# All of the RPC_* functions are convenience-encoders
sub RPC_STRING ($)
{
    return RPC::XML::string->new(shift);
}
sub RPC_BOOLEAN ($)
{
    return RPC::XML::boolean->new(shift);
}
sub RPC_INT ($)
{
    return RPC::XML::int->new(shift);
}
sub RPC_I4 ($)
{
    return RPC::XML::i4->new(shift);
}
sub RPC_I8 ($)
{
    return RPC::XML::i8->new(shift);
}
sub RPC_DOUBLE ($)
{
    return RPC::XML::double->new(shift);
}
sub RPC_DATETIME_ISO8601 ($)
{
    return RPC::XML::datetime_iso8601->new(shift);
}
sub RPC_BASE64 ($;$)
{
    return RPC::XML::base64->new(shift, shift);
}
sub RPC_NIL ()
{
    return RPC::XML::nil->new();
}

# This is a dead-simple ISO8601-from-UNIX-time stringifier. Always expresses
# time in UTC. The format isn't strictly ISO8601, though, as the XML-RPC spec
# fucked it up.
sub time2iso8601
{
    my $time = shift || time;

    my @time = gmtime $time;
    $time = sprintf '%4d%02d%02dT%02d:%02d:%02dZ',
                    $time[5] + 1900, $time[4] + 1, @time[3, 2, 1, 0];

    return $time;
}

# This is a (futile?) attempt to provide a "smart" encoding method that will
# take a Perl scalar and promote it to the appropriate RPC::XML::_type_.
{
    my $MAX_INT      = 2_147_483_647;
    my $MIN_INT      = -2_147_483_648;
    my $MAX_BIG_INT   = 9_223_372_036_854_775_807;
    my $MIN_BIG_INT   = -9_223_372_036_854_775_808;

    my $MAX_DOUBLE   = 1e37;
    my $MIN_DOUBLE   = $MAX_DOUBLE * -1;

    sub smart_encode ## no critic (ProhibitExcessComplexity)
    {
        my @values = @_;
        my ($type, $seenrefs, @newvalues);

        # Look for sooper-sekrit pseudo-blessed hashref as first argument.
        # It means this is a recursive call, and it contains a map of any
        # references we've already seen.
        if ((blessed $values[0]) && ($values[0]->isa('RPC::XML::refmap')))
        {
            # Peel it off of the list
            $seenrefs = shift @values;
        }
        else
        {
            # Create one just in case we need it
            $seenrefs = bless {}, 'RPC::XML::refmap';
        }

        foreach (@values)
        {
            if (! defined $_)
            {
                $type = $ALLOW_NIL ?
                    RPC::XML::nil->new() : RPC::XML::string->new(q{});
            }
            elsif (ref $_)
            {
                # Skip any that we've already seen
                next if $seenrefs->{$_}++;

                if (blessed($_) &&
                    ($_->isa('RPC::XML::datatype') || $_->isa('DateTime')))
                {
                    # Only if the reference is a datatype or a DateTime
                    # instance, do we short-cut here...

                    if ($_->isa('RPC::XML::datatype'))
                    {
                        # Pass through any that have already been encoded
                        $type = $_;
                    }
                    else
                    {
                        # Must be a DateTime object, convert to ISO8601
                        $type = RPC::XML::datetime_iso8601
                            ->new($_->clone->set_time_zone('UTC'));
                    }
                }
                elsif (reftype($_) eq 'HASH')
                {
                    # Per RT 41063, to catch circular refs I can't delegate
                    # to the struct constructor, I have to create my own
                    # copy of the hash with locally-recursively-encoded
                    # values
                    my %newhash;
                    for my $key (keys %{$_})
                    {
                        # Forcing this into a list-context *should* make the
                        # test be true even if the return value is a hard
                        # undef. Only if the return value is an empty list
                        # should this evaluate as false...
                        if (my @value = smart_encode($seenrefs, $_->{$key}))
                        {
                            $newhash{$key} = $value[0];
                        }
                    }

                    $type = RPC::XML::struct->new(\%newhash);
                }
                elsif (reftype($_) eq 'ARRAY')
                {
                    # This is a somewhat-ugly approach, but I don't want to
                    # dereference @$_, but I also want people to be able to
                    # pass array-refs in to this constructor and have them
                    # be treated as single elements, as one would expect
                    # (see RT 35106)
                    # Per RT 41063, looks like I get to deref $_ after all...
                    $type = RPC::XML::array->new(
                        from => [ smart_encode($seenrefs, @{$_}) ]
                    );
                }
                elsif (reftype($_) eq 'SCALAR')
                {
                    # This is a rare excursion into recursion, since the scalar
                    # nature (de-refed from the object, so no longer magic)
                    # will prevent further recursing.
                    $type = smart_encode($seenrefs, ${$_});
                }
                else
                {
                    # If the user passed in a reference that didn't pass one
                    # of the above tests, we can't do anything with it:
                    $type = reftype $_;
                    die "Un-convertable reference: $type, cannot use\n";
                }
                $seenrefs->{$_}--;
            }
            # You have to check ints first, because they match the
            # next pattern (for doubles) too
            elsif (! $FORCE_STRING_ENCODING &&
                   /^[-+]?\d+$/ &&
                   $_ >= $MIN_BIG_INT &&
                   $_ <= $MAX_BIG_INT)
            {
                if (($_ > $MAX_INT) || ($_ < $MIN_INT))
                {
                    $type = RPC::XML::i8->new($_);
                }
                else
                {
                    $type = RPC::XML::int->new($_);
                }
            }
            # Pattern taken from perldata(1)
            elsif (! $FORCE_STRING_ENCODING &&
                   /^[+-]?(?=\d|[.]\d)\d*(?:[.]\d*)?(?:[Ee](?:[+-]?\d+))?$/x &&
                   $_ > $MIN_DOUBLE &&
                   $_ < $MAX_DOUBLE)
            {
                $type = RPC::XML::double->new($_);
            }
            elsif (/$DATETIME_REGEXP/)
            {
                $type = RPC::XML::datetime_iso8601->new($_);
            }
            else
            {
                $type = RPC::XML::string->new($_);
            }

            push @newvalues, $type;
        }

        return (wantarray ? @newvalues : $newvalues[0]);
    }
}

# This is a (mostly) empty class used as a common superclass for simple and
# complex types, so that their derivatives may be universally type-checked.
package RPC::XML::datatype;

sub type
{
    my $self = shift;

    my $class = ref($self) || $self;
    $class =~ s/.*://;

    return $class;
}

sub is_fault { return 0; }

###############################################################################
#
#   Package:        RPC::XML::simple_type
#
#   Description:    A base class for the simpler type-classes to inherit from,
#                   for default constructor, stringification, etc.
#
###############################################################################
package RPC::XML::simple_type;

use strict;
use base 'RPC::XML::datatype';

use Scalar::Util 'reftype';

# new - a generic constructor that presumes the value being stored is scalar
sub new
{
    my $class = shift;
    my $value = shift;

    $RPC::XML::ERROR = q{};
    $class = ref($class) || $class;

    if ($class eq 'RPC::XML::simple_type')
    {
        $RPC::XML::ERROR = 'RPC::XML::simple_type::new: Cannot instantiate ' .
            'this class directly';
        return;
    }

    if (ref $value)
    {
        # If it is a scalar reference, just deref
        if (reftype($value) eq 'SCALAR')
        {
            $value = ${$value};
        }
        else
        {
            # We can only manage scalar references (or blessed scalar refs)
            $RPC::XML::ERROR = "${class}::new: Cannot instantiate from a " .
                'reference not derived from scalar';
            return;
        }
    }

    return bless \$value, $class;
}

# value - a generic accessor
sub value
{
    my $self = shift;

    if (! ref $self)
    {
        $RPC::XML::ERROR =
            "{$self}::value: Cannot be called as a static method";
        return;
    }

    return ${$self};
}

# as_string - return the value as an XML snippet
sub as_string
{
    my $self = shift;

    my $class = ref $self;
    if (! $class)
    {
        $RPC::XML::ERROR =
            "{$self}::as_string: Cannot be called as a static method";
        return;
    }
    $class =~ s/^.*\://;
    $class =~ s/_/./g;
    if (substr($class, 0, 8) eq 'datetime')
    {
        substr $class, 0, 8, 'dateTime';
    }

    return "<$class>${$self}";
}

# Serialization for simple types is just a matter of sending as_string over
sub serialize
{
    my ($self, $fh) = @_;

    utf8::encode(my $str = $self->as_string);
    print {$fh} $str;

    return;
}

# The switch to serialization instead of in-memory strings means having to
# calculate total size in bytes for Content-Length headers:
sub length ## no critic (ProhibitBuiltinHomonyms)
{
    my $self = shift;

    utf8::encode(my $str = $self->as_string);

    return length $str;
}

###############################################################################
#
#   Package:        RPC::XML::int
#
#   Description:    Data-type class for integers
#
###############################################################################
package RPC::XML::int;

use strict;
use base 'RPC::XML::simple_type';

###############################################################################
#
#   Package:        RPC::XML::i4
#
#   Description:    Data-type class for i4. Forces data into an int object.
#
###############################################################################
package RPC::XML::i4;

use strict;
use base 'RPC::XML::simple_type';

###############################################################################
#
#   Package:        RPC::XML::i8
#
#   Description:    Data-type class for i8. Forces data into a 8-byte int.
#
###############################################################################
package RPC::XML::i8;

use strict;
use base 'RPC::XML::simple_type';

###############################################################################
#
#   Package:        RPC::XML::double
#
#   Description:    The "double" type-class
#
###############################################################################
package RPC::XML::double;

use strict;
use base 'RPC::XML::simple_type';

sub as_string
{
    my $self = shift;

    if (! ref $self)
    {
        $RPC::XML::ERROR =
            "{$self}::as_string: Cannot be called as a static method";
        return;
    }
    my $class = $self->type;

    (my $value = sprintf '%.20f', ${$self}) =~ s/([.]\d+?)0+$/$1/;

    return "<$class>$value";
}

###############################################################################
#
#   Package:        RPC::XML::string
#
#   Description:    The "string" type-class
#
###############################################################################
package RPC::XML::string;

use strict;
use base 'RPC::XML::simple_type';

# as_string - return the value as an XML snippet
sub as_string
{
    my $self = shift;

    my ($class, $value);

    if (! ref $self)
    {
        $RPC::XML::ERROR =
            "{$self}::as_string: Cannot be called as a static method";
        return;
    }
    $class = $self->type;

    ($value = defined ${$self} ? ${$self} : q{} )
        =~ s/$RPC::XML::XMLRE/$RPC::XML::XMLMAP{$1}/ge;

    return "<$class>$value";
}

###############################################################################
#
#   Package:        RPC::XML::boolean
#
#   Description:    The type-class for boolean data. Handles some "extra" cases
#
###############################################################################
package RPC::XML::boolean;

use strict;
use base 'RPC::XML::simple_type';

# This constructor allows any of true, false, yes or no to be specified
sub new
{
    my $class = shift;
    my $value = shift || 0;

    $RPC::XML::ERROR = q{};
    if ($value =~ /true|yes|1/i)
    {
        $value = 1;
    }
    elsif ($value =~ /false|no|0/i)
    {
        $value = 0;
    }
    else
    {
        $class = ref($class) || $class;
        $RPC::XML::ERROR = "${class}::new: Value must be one of yes, no, " .
            'true, false, 1, 0 (case-insensitive)';
        return;
    }

    return bless \$value, $class;
}

###############################################################################
#
#   Package:        RPC::XML::datetime_iso8601
#
#   Description:    This is the class to manage ISO8601-style date/time values
#
###############################################################################
package RPC::XML::datetime_iso8601;

use strict;
use base 'RPC::XML::simple_type';

use Scalar::Util 'reftype';

sub type { return 'dateTime.iso8601'; };

# Check the value passed in for sanity, and normalize the string representation
sub new
{
    my ($class, $value) = @_;
    my $newvalue;

    if (ref($value) && reftype($value) eq 'SCALAR')
    {
        $value = ${$value};
    }

    if (defined $value)
    {
        if ($value =~ /$RPC::XML::DATETIME_REGEXP/)
        {
            # This is *not* a valid ISO 8601 format, but it's the way it is
            # given in the spec, so assume that other implementations can only
            # accept this form. Also, this should match the form that
            # time2iso8601 produces.
            $newvalue = $7 ? "$1$2$3T$4:$5:$6$7" : "$1$2$3T$4:$5:$6";
            if ($8) {
                $newvalue .= $8;
            }
        }
        elsif ($RPC::XML::DATETIME_ISO8601_AVAILABLE)
        {
            $newvalue =
                eval { DateTime::Format::ISO8601->parse_datetime($value) };
            if ($newvalue)
            {
                # This both removes the dashes (*sigh*) and forces it from an
                # object to an ordinary string:
                $newvalue =~ s/-//g;
            }
        }

        if (! $newvalue)
        {
            $RPC::XML::ERROR = "${class}::new: Malformed data ($value) " .
                'passed as dateTime.iso8601';
            return;
        }
    }
    else
    {
        $RPC::XML::ERROR = "${class}::new: Value required in constructor";
        return;
    }

    return bless \$newvalue, $class;
}

###############################################################################
#
#   Package:        RPC::XML::nil
#
#   Description:    The "nil" type-class extension
#
###############################################################################
package RPC::XML::nil;

use strict;
use base 'RPC::XML::simple_type';

# no value need be passed to this method
sub new
{
    my ($class, $value, $flag) = @_;
    # We need $value so we can bless a reference to it. But regardless of
    # what was passed, it needs to be undef to be a proper "nil".
    undef $value;

    if (! $RPC::XML::ALLOW_NIL && ! $flag)
    {
        $RPC::XML::ERROR = "${class}::new: \$RPC::XML::ALLOW_NIL must be set" .
            ' for RPC::XML::nil objects to be supported';
        return;
    }

    return bless \$value, $class;
}

# Stringification and serialsation are trivial..
sub as_string
{
    return '';
}

sub serialize
{
    my ($self, $fh) = @_;

    print {$fh} $self->as_string; # In case someone sub-classes this

    return;
}

###############################################################################
#
#   Package:        RPC::XML::array
#
#   Description:    This class encapsulates the array data type. Each element
#                   within the array should be one of the datatype classes.
#
###############################################################################
package RPC::XML::array;

use strict;
use base 'RPC::XML::datatype';

use Scalar::Util qw(blessed reftype);

# The constructor for this class mainly needs to sanity-check the value data
sub new
{
    my ($class, @args) = @_;

    # Special-case time: If the args-list has exactly two elements, and the
    # first element is "from" and the second element is an array-ref (or a
    # type derived from), then copy the ref's contents into @args.
    if ((2 == @args) && ($args[0] eq 'from') && (reftype($args[1]) eq 'ARRAY'))
    {
        @args = @{$args[1]};
    }

    # Ensure that each argument passed in is itself one of the data-type
    # class instances.
    return bless [ RPC::XML::smart_encode(@args) ], $class;
}

# This became more complex once it was shown that there may be a need to fetch
# the value while preserving the underlying objects.
sub value
{
    my $self = shift;
    my $no_recurse = shift || 0;
    my $ret;

    if ($no_recurse)
    {
        $ret = [ @{$self} ];
    }
    else
    {
        $ret = [ map { $_->value } @{$self} ];
    }

    return $ret;
}

sub as_string
{
    my $self = shift;

    return join q{},
                '',
                (map { ('', $_->as_string(), '') } (@{$self})),
                '';
}

# Serialization for arrays is not as straight-forward as it is for simple
# types. One or more of the elements may be a base64 object, which has a
# non-trivial serialize() method. Thus, rather than just sending the data from
# as_string down the pipe, instead call serialize() recursively on all of the
# elements.
sub serialize
{
    my ($self, $fh) = @_;

    print {$fh} '';
    for (@{$self})
    {
        print {$fh} '';
        $_->serialize($fh);
        print {$fh} '';
    }
    print {$fh} '';

    return;
}

# Length calculation starts to get messy here, due to recursion
sub length ## no critic (ProhibitBuiltinHomonyms)
{
    my $self = shift;

    # Start with the constant components in the text
    my $len = 28; # That the  part
    for (@{$self}) { $len += (15 + $_->length) } # 15 is for

    return $len;
}

###############################################################################
#
#   Package:        RPC::XML::struct
#
#   Description:    This is the "struct" data class. The struct is like Perl's
#                   hash, with the constraint that all values are instances
#                   of the datatype classes.
#
###############################################################################
package RPC::XML::struct;

use strict;
use base 'RPC::XML::datatype';

use Scalar::Util qw(blessed reftype);

# The constructor for this class mainly needs to sanity-check the value data
sub new
{
    my ($class, @args) = @_;
    my %args = (ref $args[0] and reftype($args[0]) eq 'HASH') ?
        %{$args[0]} : @args;

    # RT 41063: If all the values are datatype objects, either they came in
    # that way or we've already laundered them through smart_encode(). If there
    # is even one that isn't, then we have to pass the whole mess to be
    # encoded.
    my $ref =
        (grep { ! (blessed($_) && $_->isa('RPC::XML::datatype')) } values %args)
            ? RPC::XML::smart_encode(\%args) : \%args;

    return bless $ref, $class;
}

# This became more complex once it was shown that there may be a need to fetch
# the value while preserving the underlying objects.
sub value
{
    my $self = shift;
    my $no_recurse = shift || 0;
    my %value;

    if ($no_recurse)
    {
        %value = map { ($_, $self->{$_}) } (keys %{$self});
    }
    else
    {
        %value = map { ($_, $self->{$_}->value) } (keys %{$self});
    }

    return \%value;
}

sub as_string
{
    my $self = shift;
    my $key;

    # Clean the keys of $self, in case they have any HTML-special characters
    my %clean;
    for (keys %{$self})
    {
        ($key = $_) =~ s/$RPC::XML::XMLRE/$RPC::XML::XMLMAP{$1}/ge;
        $clean{$key} = $self->{$_}->as_string;
    }

    return join q{},
                '',
                (map {
                    ("$_",
                     $clean{$_},
                     '')
                } (keys %clean)),
                '';
}

# As with the array type, serialization here isn't cut and dried, since one or
# more values may be base64.
sub serialize
{
    my ($self, $fh) = @_;
    my $key;

    print {$fh} '';
    for (keys %{$self})
    {
        ($key = $_) =~ s/$RPC::XML::XMLRE/$RPC::XML::XMLMAP{$1}/ge;
        utf8::encode($key);
        print {$fh} "$key";
        $self->{$_}->serialize($fh);
        print {$fh} '';
    }
    print {$fh} '';

    return;
}

# Length calculation is a real pain here. But not as bad as base64 promises
sub length ## no critic (ProhibitBuiltinHomonyms)
{
    my $self = shift;

    my $len = 17; #
    for my $key (keys %{$self})
    {
        $len += 45; # For all the constant XML presence
        $len += $self->{$key}->length;
        utf8::encode($key);
        $len += length $key;
    }

    return $len;
}

###############################################################################
#
#   Package:        RPC::XML::base64
#
#   Description:    This is the base64-encoding type. Plain data is passed in,
#                   plain data is returned. Plain is always returned. All the
#                   encoding/decoding is done behind the scenes.
#
###############################################################################
package RPC::XML::base64;

use strict;
use base 'RPC::XML::datatype';

use Scalar::Util 'reftype';

sub new
{
    my ($class, $value, $encoded) = @_;

    require MIME::Base64;

    my $self = {};

    $RPC::XML::ERROR = q{};

    $self->{encoded} = $encoded ? 1 : 0; # Is this already Base-64?
    $self->{inmem}   = 0;                # To signal in-memory vs. filehandle

    # First, determine if the call sent actual data, a reference to actual
    # data, or an open filehandle.
    if (ref $value and reftype($value) eq 'GLOB')
    {
        # This is a seekable filehandle (or acceptable substitute thereof).
        # This assignment increments the ref-count, and prevents destruction
        # in other scopes.
        binmode $value;
        $self->{value_fh} = $value;
        $self->{fh_pos}   = tell $value;
    }
    else
    {
        # Not a filehandle. Might be a scalar ref, but other than that it's
        # in-memory data.
        $self->{inmem}++;
        $self->{value} = ref($value) ? ${$value} : ($value || q{});
        # We want in-memory data to always be in the clear, to reduce the tests
        # needed in value(), below.
        if ($self->{encoded})
        {
            local $^W = 0; # Disable warnings in case the data is underpadded
            $self->{value} = MIME::Base64::decode_base64($self->{value});
            $self->{encoded} = 0;
        }
    }

    return bless $self, $class;
}

sub value
{
    my ($self, $flag) = @_;
    my $as_base64 = (defined $flag and $flag) ? 1 : 0;

    # There are six cases here, based on whether or not the data exists in
    # Base-64 or clear form, and whether the data is in-memory or needs to be
    # read from a filehandle.
    if ($self->{inmem})
    {
        # This is simplified into two cases (rather than four) since we always
        # keep in-memory data as cleartext
        return $as_base64 ?
            MIME::Base64::encode_base64($self->{value}, q{}) : $self->{value};
    }
    else
    {
        # This is trickier with filehandle-based data, since we chose not to
        # change the state of the data. Thus, the behavior is dependant not
        # only on $as_base64, but also on $self->{encoded}. This is why we
        # took pains to explicitly set $as_base64 to either 0 or 1, rather than
        # just accept whatever non-false value the caller sent. It makes this
        # first test possible.
        my ($accum, $pos, $res);
        $accum = q{};

        $self->{fh_pos} = tell $self->{value_fh};
        seek $self->{value_fh}, 0, 0;
        if ($as_base64 == $self->{encoded})
        {
            $pos = 0;
            while ($res = read $self->{value_fh}, $accum, 1024, $pos)
            {
                $pos += $res;
            }
        }
        else
        {
            if ($as_base64)
            {
                # We're reading cleartext and converting it to Base-64. Read in
                # multiples of 57 bytes for best Base-64 calculation. The
                # choice of 60 for the multiple is purely arbitrary.
                $res = q{};
                while (read $self->{value_fh}, $res, 60*57)
                {
                    $accum .= MIME::Base64::encode_base64($res, q{});
                }
            }
            else
            {
                # Reading Base-64 and converting it back to cleartext. If the
                # Base-64 data doesn't have any line-breaks, no telling how
                # much memory this will eat up.
                local $^W = 0; # Disable padding-length warnings
                $pos = $self->{value_fh};
                while (defined($res = <$pos>))
                {
                    $accum .= MIME::Base64::decode_base64($res);
                }
            }
        }
        seek $self->{value_fh}, $self->{fh_pos}, 0;

        return $accum;
    }
}

# The value needs to be encoded before being output
sub as_string
{
    my $self = shift;

    return '' . $self->value('encoded') . '';
}

# If it weren't for Tellme and their damnable WAV files, and ViAir and their
# half-baked XML-RPC server, I wouldn't have to do any of this...
#
# (On the plus side, at least here I don't have to worry about encodings...)
sub serialize
{
    my ($self, $fh) = @_;

    # If the data is in-memory, just call as_string and pass it down the pipe
    if ($self->{inmem})
    {
        print {$fh} $self->as_string;
    }
    else
    {
        # If it's a filehandle, at least we take comfort in knowing that we
        # always want Base-64 at this level.
        my $buf = q{};
        $self->{fh_pos} = tell $self->{value_fh};
        seek $self->{value_fh}, 0, 0;
        print {$fh} '';
        if ($self->{encoded})
        {
            # Easy-- just use read() to send it down in palatably-sized chunks
            while (read $self->{value_fh}, $buf, 4096)
            {
                print {$fh} $buf;
            }
        }
        else
        {
            # This actually requires work. As with value(), the 60*57 is based
            # on ideal Base-64 chunks, with the 60 part being arbitrary.
            while (read $self->{value_fh}, $buf, 60*57)
            {
                print {$fh} MIME::Base64::encode_base64($buf, q{});
            }
        }
        print {$fh} '';
        seek $self->{value_fh}, $self->{fh_pos}, 0;
    }

    return;
}

# This promises to be a big enough pain that I seriously considered opening
# an anon-temp file (one that's unlinked for security, and survives only as
# long as the FH is open) and passing that to serialize just to -s on the FH.
# But I'll do this the "right" way instead...
sub length ## no critic (ProhibitBuiltinHomonyms)
{
    my $self = shift;

    # Start with the constant bits
    my $len = 17; #

    if ($self->{inmem})
    {
        # If it's in-memory, it's cleartext. Size the encoded version
        $len += length(MIME::Base64::encode_base64($self->{value}, q{}));
    }
    else
    {
        if ($self->{encoded})
        {
            # We're lucky, it's already encoded in the file, and -s will do
            $len += -s $self->{value_fh};
        }
        else
        {
            # Oh bugger. We have to encode it.
            my $buf = q{};
            my $cnt = 0;

            $self->{fh_pos} = tell $self->{value_fh};
            seek $self->{value_fh}, 0, 0;
            while ($cnt = read $self->{value_fh}, $buf, 60*57)
            {
                $len += length(MIME::Base64::encode_base64($buf, q{}));
            }
            seek $self->{value_fh}, $self->{fh_pos}, 0;
        }
    }

    return $len;
}

# This allows writing the decoded data to an arbitrary file. It's useful when
# an application has gotten a RPC::XML::base64 object back from a request, and
# knows that it needs to go straight to a file without being completely read
# into memory, first.
sub to_file
{
    my ($self, $file) = @_;

    my ($fh, $buf, $do_close, $count) = (undef, q{}, 0, 0);

    if (ref $file)
    {
        if (reftype($file) eq 'GLOB')
        {
            $fh = $file;
        }
        else
        {
            $RPC::XML::ERROR = 'Unusable reference type passed to to_file';
            return -1;
        }
    }
    else
    {
        if (! open $fh, '>', $file) ## no critic (RequireBriefOpen)
        {
            $RPC::XML::ERROR = "Error opening $file for writing: $!";
            return -1;
        }
        binmode $fh;
        $do_close++;
    }

    # If all the data is in-memory, then we know that it's clear, and we
    # don't have to jump through hoops in moving it to the filehandle.
    if ($self->{inmem})
    {
        print {$fh} $self->{value};
        $count = CORE::length($self->{value});
    }
    else
    {
        # Filehandle-to-filehandle transfer.

        # Now determine if the data can be copied over directly, or if we have
        # to decode it along the way.
        $self->{fh_pos} = tell $self->{value_fh};
        seek $self->{value_fh}, 0, 0;
        if ($self->{encoded})
        {
            # As with the caveat in value(), if the base-64 data doesn't have
            # any line-breaks, no telling how much memory this will eat up.
            local $^W = 0; # Disable padding-length warnings
            my $tmp_fh = $self->{value_fh};
            while (defined($_ = <$tmp_fh>))
            {
                $buf = MIME::Base64::decode_base64($_);
                print {$fh} $buf;
                $count += CORE::length($buf);
            }
        }
        else
        {
            # If the data is already decoded in the filehandle, then just copy
            # it over.
            my $size;
            while ($size = read $self->{value_fh}, $buf, 4096)
            {
                print {$fh} $buf;
                $count += $size;
            }
        }

        # Restore the position of the file-pointer for the internal FH
        seek $self->{value_fh}, $self->{fh_pos}, 0;
    }

    if ($do_close)
    {
        if (! close $fh)
        {
            $RPC::XML::ERROR = "Error closing $file after writing: $!";
            return -1;
        }
    }

    return $count;
}

###############################################################################
#
#   Package:        RPC::XML::fault
#
#   Description:    This is the class that encapsulates the data for a RPC
#                   fault-response. Like the others, it takes the relevant
#                   information and maintains it internally. This is put
#                   at the end of the datum types, though it isn't really a
#                   data type in the sense that it cannot be passed in to a
#                   request. But it is separated so as to better generalize
#                   responses.
#
###############################################################################
package RPC::XML::fault;

use strict;
use base 'RPC::XML::struct';

use Scalar::Util 'blessed';

# For our new(), we only need to ensure that we have the two required members
sub new
{
    my ($class, @args) = @_;

    my %args;

    $RPC::XML::ERROR = q{};
    if (blessed $args[0] and $args[0]->isa('RPC::XML::struct'))
    {
        # Take the keys and values from the struct object as our own
        %args = %{$args[0]->value('shallow')};
    }
    elsif ((@args == 2) && ($args[0] =~ /^-?\d+$/) && length $args[1])
    {
        # This is a special convenience-case to make simple new() calls clearer
        %args = (faultCode   => RPC::XML::int->new($args[0]),
                 faultString => RPC::XML::string->new($args[1]));
    }
    else
    {
        %args = @args;
    }

    if (! ($args{faultCode} and $args{faultString}))
    {
        $class = ref($class) || $class;
        $RPC::XML::ERROR = "${class}::new: Missing required struct fields";
        return;
    }
    if (scalar(keys %args) > 2)
    {
        $class = ref($class) || $class;
        $RPC::XML::ERROR = "${class}::new: Extra struct fields not allowed";
        return;
    }

    return $class->SUPER::new(%args);
}

# This only differs from the display of a struct in that it has some extra
# wrapped around it. Let the superclass as_string method do most of the work.
sub as_string
{
    my $self = shift;

    return '' . $self->SUPER::as_string . '';
}

# Again, only differs from struct in that it has some extra wrapped around it.
sub serialize
{
    my ($self, $fh) = @_;

    print {$fh} '';
    $self->SUPER::serialize($fh);
    print {$fh} '';

    return;
}

# Because of the slight diff above, length() has to be different from struct
sub length ## no critic (ProhibitBuiltinHomonyms)
{
    my $self = shift;

    return $self->SUPER::length + 30; # For constant XML content
}

# Convenience methods:
sub code   { return shift->{faultCode}->value;   }
sub string { return shift->{faultString}->value; }

# This is the only one to override this method, for obvious reasons
sub is_fault { return 1; }

###############################################################################
#
#   Package:        RPC::XML::request
#
#   Description:    This is the class that encapsulates the data for a RPC
#                   request. It takes the relevant information and maintains
#                   it internally until asked to stringify. Only then is the
#                   XML generated, encoding checked, etc. This allows for
#                   late-selection of  or  as a
#                   containing tag.
#
#                   This class really only needs a constructor and a method
#                   to stringify.
#
###############################################################################
package RPC::XML::request;

use strict;

use Scalar::Util 'blessed';

###############################################################################
#
#   Sub Name:       new
#
#   Description:    Creating a new request object, in this (reference) case,
#                   means checking the list of arguments for sanity and
#                   packaging it up for later use.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $class    in      scalar    Class/ref to bless into
#                   @argz     in      list      The exact disposition of the
#                                                 arguments is based on the
#                                                 type of the various elements
#
#   Returns:        Success:    object ref
#                   Failure:    undef, error in $RPC::XML::ERROR
#
###############################################################################
sub new
{
    my ($class, @argz) = @_;

    my $name;

    $class = ref($class) || $class;
    $RPC::XML::ERROR = q{};

    if (! @argz)
    {
        $RPC::XML::ERROR = 'RPC::XML::request::new: At least a method name ' .
            'must be specified';
        return;
    }

    # This is the method name to be called
    $name = shift @argz;
    # Is it valid?
    if ($name !~ m{^[\w.:/]+$})
    {
        $RPC::XML::ERROR =
            'RPC::XML::request::new: Invalid method name specified';
        return;
    }

    # All the remaining args must be data.
    @argz = RPC::XML::smart_encode(@argz);

    return bless { args => [ @argz ], name => $name }, $class;
}

# Accessor methods
sub name { return shift->{name}; }
sub args { return shift->{args}; }

###############################################################################
#
#   Sub Name:       as_string
#
#   Description:    This is a fair bit more complex than the simple as_string
#                   methods for the datatypes. Express the invoking object as
#                   a well-formed XML document.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Invoking object
#                   $indent   in      scalar    Indention level for output
#
#   Returns:        Success:    text
#                   Failure:    undef
#
###############################################################################
sub as_string
{
    my $self   = shift;

    my $text;

    $RPC::XML::ERROR = q{};

    $text = qq();

    $text .= "$self->{name}";
    for (@{$self->{args}})
    {
        $text .= '' . $_->as_string . '';
    }
    $text .= '';

    return $text;
}

# The difference between stringifying and serializing a request is much like
# the difference was for structs and arrays. The boilerplate is the same, but
# the destination is different in a sensitive way.
sub serialize
{
    my ($self, $fh) = @_;
    utf8::encode(my $name = $self->{name});

    print {$fh} qq();

    print {$fh} "$name";
    for (@{$self->{args}})
    {
        print {$fh} '';
        $_->serialize($fh);
        print {$fh} '';
    }
    print {$fh} '';

    return;
}

# Compared to base64, length-calculation here is pretty easy, much like struct
sub length ## no critic (ProhibitBuiltinHomonyms)
{
    my $self = shift;

    my $len = 100 + length $RPC::XML::ENCODING; # All the constant XML present
    utf8::encode(my $name = $self->{name});
    $len += length $name;

    for (@{$self->{args}})
    {
        $len += 30; # Constant XML
        $len += $_->length;
    }

    return $len;
}

###############################################################################
#
#   Package:        RPC::XML::response
#
#   Description:    This is the class that encapsulates the data for a RPC
#                   response. As above, it takes the information and maintains
#                   it internally until asked to stringify. Only then is the
#                   XML generated, encoding checked, etc. This allows for
#                   late-selection of  or
#                   as above.
#
###############################################################################
package RPC::XML::response;

use strict;

use Scalar::Util 'blessed';

###############################################################################
#
#   Sub Name:       new
#
#   Description:    Creating a new response object, in this (reference) case,
#                   means checking the outgoing parameter(s) for sanity.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $class    in      scalar    Class/ref to bless into
#                   @argz     in      list      The exact disposition of the
#                                                 arguments is based on the
#                                                 type of the various elements
#
#   Returns:        Success:    object ref
#                   Failure:    undef, error in $RPC::XML::ERROR
#
###############################################################################
sub new
{
    my ($class, @argz) = @_;

    $class = ref($class) || $class;

    $RPC::XML::ERROR = q{};
    if (! @argz)
    {
        $RPC::XML::ERROR = 'RPC::XML::response::new: One of a datatype, ' .
            'value or a fault object must be specified';
        return;
    }
    elsif (@argz > 1)
    {
        $RPC::XML::ERROR = 'RPC::XML::response::new: Responses may take ' .
            'only one argument';
        return;
    }

    $argz[0] = RPC::XML::smart_encode($argz[0]);

    return bless { value => $argz[0] }, $class;
}

# Accessor/status methods
sub value      { return shift->{value}; }
sub is_fault   { return shift->{value}->is_fault; }

###############################################################################
#
#   Sub Name:       as_string
#
#   Description:    This is a fair bit more complex than the simple as_string
#                   methods for the datatypes. Express the invoking object as
#                   a well-formed XML document.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Invoking object
#                   $indent   in      scalar    Indention level for output
#
#   Returns:        Success:    text
#                   Failure:    undef
#
###############################################################################
sub as_string
{
    my $self   = shift;

    my $text;

    $RPC::XML::ERROR = q{};

    $text = qq();

    $text .= '';
    if ($self->{value}->isa('RPC::XML::fault'))
    {
        $text .= $self->{value}->as_string;
    }
    else
    {
        $text .= '' . $self->{value}->as_string .
            '';
    }
    $text .= '';

    return $text;
}

# See the comment for serialize() above in RPC::XML::request
sub serialize
{
    my ($self, $fh) = @_;

    print {$fh} qq();

    print {$fh} '';
    if ($self->{value}->isa('RPC::XML::fault'))
    {
        # A fault lacks the params-boilerplate
        $self->{value}->serialize($fh);
    }
    else
    {
        print {$fh} '';
        $self->{value}->serialize($fh);
        print {$fh} '';
    }
    print {$fh} '';

    return;
}

# Compared to base64, length-calculation here is pretty easy, much like struct
sub length ## no critic (ProhibitBuiltinHomonyms)
{
    my $self = shift;

    my $len = 66 + length $RPC::XML::ENCODING; # All the constant XML present

    # This boilerplate XML is only present when it is NOT a fault
    if (! $self->{value}->isa('RPC::XML::fault'))
    {
        $len += 47;
    }

    $len += $self->{value}->length;

    return $len;
}

1;

__END__