File Coverage

blib/lib/WDDX.pm

Criterion	Covered	Total	%
statement	9	140	6.4
branch	0	68	0.0
condition	0	15	0.0
subroutine	3	28	10.7
pod			n/a
total	12	251	4.7

package WDDX;

=head1 NAME

WDDX.pm - Module for reading and writing WDDX packets

=head1 VERSION

Version 1.02

    $Header: /home/cvs/wddx/WDDX.pm,v 1.4 2003/12/02 03:41:10 andy Exp $

=cut

use vars qw( $VERSION );
$VERSION = "1.02";

=head1 NAME


=head1 SYNOPSIS

 use WDDX;
 my $wddx = new WDDX;

 # Serialization example

 my $wddx_hash = $wddx->hash( {
         str     =>  $wddx->string( "Welcome to WDDX!\n" ),
         num     =>  $wddx->number( -12.456 ),
         date    =>  $wddx->datetime( date ),
         bool    =>  $wddx->boolean( 1 ),
         arr     =>  $wddx->array( [
                     $wddx->boolean( 0 ),
                     $wddx->number( 10 ),
                     $wddx->string( "third element" ),
                 ] ),
         rec     =>  $wddx->recordset(
                     [ "NAME", "AGE" ],
                     [ "string", "number" ],
                     [
                         [ "John Doe", 34 ],
                         [ "Jane Doe", 25 ],
                         [ "Fred Doe", 90 ],
                     ]
                 ),
         obj     =>  $wddx->hash( {
                     str => $wddx->string( "a string" ),
                     num => $wddx->number( 3.14159 ),
                 } ),
         bin     => $wddx->binary( $img_data ),
         null    => $wddx->null(),
     } );

 print $wddx->header;
 print $wddx->serialize( $wddx_hash );

 # Deserialization example

 my $wddx_request = $wddx->deserialize( $packet );

 # Assume that our code expects an array
 $wddx_request->type eq "array" or die "Invalid request";
 my $array_ref = $wddx_request->as_arrayref;


=head1 DESCRIPTION

=head2 About WDDX

From L:

=over 4

The Web Distributed Data Exchange, or WDDX, is a free, open XML-based
technology that allows Web applications created with any platform to
easily exchange data with one another over the Web.

=back

=head2 WDDX and Perl

WDDX defines basic data types that mirror the data types available in
other common programming languages. Many of these data types don't
have corresponding data types in Perl. To Perl, strings, numbers,
booleans, and dates are just scalars. However, in order to communicate
effectively with other languages (and this is the point of WDDX), you
do have to learn the basic WDDX data types. Here is a table that maps
the WDDX data type to Perl, along with the intermediate object WDDX.pm
represents it as:

 WDDX Type      WDDX.pm Data Object      Perl Type
 ---------      -------------------      ---------
 String         WDDX::String             Scalar
 Number         WDDX::Number             Scalar
 Boolean        WDDX::Boolean            Scalar (1 or "")
 Datetime       WDDX::Datetime           Scalar (seconds since epoch)
 Null           WDDX::Null               Scalar (undef)
 Binary         WDDX::Binary             Scalar
 Array          WDDX::Array              Array
 Struct         WDDX::Struct             Hash
 Recordset      WDDX::Recordset          WDDX::Recordset


In languages that have data types similar to the WDDX data types, the
WDDX modules allow you to convert directly from a variable to a WDDX
packet and vice versa. This Perl implementation is different; here you
must always go through an intermediate stage where the data is
represented by an object with a corresponding data type. These objects
can be converted to a WDDX packet, converted to a basic Perl type, or
converted to JavaScript code (which will recreate the data for you in
JavaScript). We will refer to these objects as I
throughout this documentation.

=head1 Requirements

This module requires L and L, which are
both available on CPAN at L. Windows users note:
These modules use compiled code, but I have been told that they are both
included with recent distributions of ActiveState Perl.

=cut

use strict;
use Carp;

require WDDX::Parser;
require WDDX::Boolean;
require WDDX::Number;
require WDDX::Datetime;
require WDDX::String;
require WDDX::Array;
require WDDX::Recordset;
require WDDX::Struct;
require WDDX::Null;
require WDDX::Binary;


# Each of these must have a corresponding WDDX::* class;
# These are lowerclass while the WDDX::* name will have initial cap
@WDDX::Data_Types = qw( boolean number string datetime null
                        array struct recordset binary );

$WDDX::XML_HEADER = "\n" .
                    "\n";
$WDDX::PACKET_HEADER = "";
$WDDX::PACKET_FOOTER = "";

# if this is defined, serialize() uses it to indent packet
$WDDX::INDENT = undef;

# Create struct() as an alias to the hash() method:
*struct = \&hash;

{ my $i_hate_the_w_flag_sometimes = [
        \@WDDX::Data_Types,
        $WDDX::XML_HEADER,
        $WDDX::PACKET_HEADER,
        $WDDX::PACKET_FOOTER,
        $WDDX::INDENT,
        \&struct,
        $WDDX::VERSION
] }

1;


=head1 METHODS

=head2 new

This creates a new WDDX object. You need one of these to do pretty much
anything else. It doesn't take any arguments.

=cut

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

    # Currently no properties maintained in WDDX object
    my $self = bless [], $class;
    return $self;
}


=head2 C<< $wddx->deserialize( $string_or_filehandle ) >>

This method deserializes a WDDX packet and returns a data object. Note
that you can pass either a string or a reference to an open filehandle
containing a packet (XML::Parser is flexible this way):

  $wddx_obj = $wddx->deserialize( $packet );     # OR
  $wddx_obj = $wddx->deserialize( \*HANDLE );

If WDDX.pm or the underlying L finds any errors with the
structure of the WDDX packet, then it will C with an error
message that identifies the problem. If you don't want this to terminate
your script, you will have to place this call within an C block
to trap the C.

=cut

sub deserialize {
    my( $self, $xml ) = @_;
    my $parser = new WDDX::Parser();

    return $parser->parse( $xml, $self );
}


=head2 C<< $wddx->serialize( $wddx_obj ) >>

This accepts a data object as an argument and returns a WDDX packet.
This method calls the as_packet() method on the data object
it receives. However, this method does provide one feature that
C does not. If C<$WDDX::INDENT> is set to a defined value,
then the generated WDDX packet is indented using C<$WDDX::INDENT>
as the unit of indentation. Otherwise packets are generated without
extra whitespace.

Note that the generated packet is not a valid XML document without the
header, see below.

=cut

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

    croak "You may only serialize WDDX data objects" unless
        eval { $data->can( "as_packet" ) };
    my $packet = eval { $data->as_packet };
    croak _shift_blame( $@ ) if $@;

    return defined( $WDDX::INDENT ) ? _xml_indent( $packet ) : $packet;
}


=head2 C<< $wddx->header >>

This returns a header that should accompany every serialized packet you
send.

=cut

sub header {
    return $WDDX::XML_HEADER;
}


sub string {
    my( $this, $value ) = @_;
    return new WDDX::String( $value );
}

sub number {
    my( $this, $value ) = @_;
    return new WDDX::Number( $value );
}

sub datetime {
    my( $this, $value ) = @_;
    return new WDDX::Datetime( $value );
}

sub boolean {
    my( $this, $value ) = @_;
    return new WDDX::Boolean( $value );
}

sub hash {
    my( $this, $hashref ) = @_;

    my $var = eval {
        new WDDX::Struct( $hashref );
    };
    croak _shift_blame( $@ ) if $@;

    return $var;
}

sub array {
    my( $this, $arrayref ) = @_;

    my $var = eval {
        new WDDX::Array( $arrayref );
    };
    croak _shift_blame( $@ ) if $@;

    return $var;
}

sub recordset {
    my( $this, $names, $types, $tableref ) = @_;

    my $var = eval {
        new WDDX::Recordset( $names, $types, $tableref );
    };
    croak _shift_blame( $@ ) if $@;

    return $var;
}

sub binary {
    my( $this, $value ) = @_;
    return new WDDX::Binary( $value );
}

sub null {
    my( $this, $value ) = @_;
    return new WDDX::Null( $value );
}


############################################################
#
# Public Utility Methods (make life easier)
#

sub scalar2wddx {
    my( $wddx, $scalar, $type ) = @_;
    $type = defined( $type ) ? lc $type : "string";

    croak "Will not encode a reference as a scalar" if ref $scalar;
    my $var = eval "WDDX::\u$type->new( \$scalar )" or
        croak "Unable to create object of type WDDX::\u$type: " .
            _shift_blame( $@ );
    return $var;
}

sub hash2wddx {
    my( $wddx, $hashref, $coderef ) = @_;
    my $new_hash = {};
    $coderef = sub { "" } unless
        defined( $coderef ) && eval { &$coderef || 1 };

    while ( my( $name, $val ) = each %$hashref ) {

        eval { $val->can( "_serialize" ) } and do {
            $new_hash->{$name} = $val;
            next;
        };

        my $type = lc $coderef->( $name => $val, "HASH" );
        if ( $type ) {
            ref( $val ) eq "HASH"  and do {
                $new_hash->{$name} = $wddx->hash2wddx ( $val, sub { $type } );
                next;
            };
            ref( $val ) eq "ARRAY" and do {
                $new_hash->{$name} = $wddx->array2wddx( $val, sub { $type } );
                next;
            };
            my $var = eval "WDDX::\u$type->new( \$val )" or
                croak "Unable to create object of type WDDX::\u$type: " .
                    _shift_blame( $@ );
            $new_hash->{$name} = $var;
            next;
        }

        ref( $val ) eq "HASH"  and do {
            $new_hash->{$name} = hash2wddx ( $wddx, $val, $coderef );
            next;
        };
        ref( $val ) eq "ARRAY" and do {
            $new_hash->{$name} = array2wddx( $wddx, $val, $coderef );
            next;
        };

        # Scalars treated as strings by default
        $new_hash->{$name} = $wddx->string( $val );
    }
    return $wddx->hash( $new_hash );
}

sub array2wddx {
    my( $wddx, $arrayref, $coderef ) = @_;
    my $new_array = [];
    $coderef = sub { "" } unless
        defined( $coderef ) && eval { &$coderef || 1 };

    for ( my $i = 0; $i < @$arrayref; $i++ ) {
        my $val = $arrayref->[$i];

        eval { $val->can( "_serialize" ) } and do {
            push @$new_array, $val;
            next;
        };

        my $type = lc $coderef->( $i => $val, "ARRAY" );
        if ( $type ) {
            ref( $val ) eq "HASH"  and do {
                push @$new_array, hash2wddx( $wddx, $val, sub { $type } );
                next;
            };
            ref( $val ) eq "ARRAY" and do {
                push @$new_array, array2wddx( $wddx, $val, sub { $type } );
                next;
            };
            my $var = eval "WDDX::\u$type->new( $i => \$val )" or
                croak "Unable to create object of type WDDX::\u$type: " .
                    _shift_blame( $@ );
            push @$new_array, $var;
            next;
        }

        ref( $val ) eq "HASH"  and do {
            push @$new_array, hash2wddx( $wddx, $val, $coderef );
            next;
        };

        ref( $val ) eq "ARRAY" and do {
            push @$new_array, array2wddx( $wddx, $val, $coderef );
            next;
        };

        # Scalars treated as strings by default
        push @$new_array, $wddx->string( $val );
    }
    return $wddx->array( $new_array );
}

sub wddx2perl {
    my( $self, $wddx_obj ) = @_;
    my $result;
    $result = $wddx_obj->as_scalar   if $wddx_obj->can( "as_scalar" );
    $result = $wddx_obj->as_hashref  if $wddx_obj->type eq "hash";
    $result = $wddx_obj->as_arrayref if $wddx_obj->type eq "array";
    $result = $wddx_obj              if $wddx_obj->type eq "recordset";
    return $result;
}


############################################################
#
# Private Subs
#

# Takes a die message and strips any internal line refs
# This is necessary because we call public methods that invoke croak
# and croak would blame us even though we're just the messenger...
sub _shift_blame {
    my $msg = shift;
    $msg =~ s/ at \S*WDDX.*\.pm line \d+//g;
    $msg =~ s/\n\nFile '.*'; Line \d+//g;   # MacPerl thinks different
    chomp $msg;
    return $msg;
}


# This uses regex matches to do indentation based on whether tag
# starts with  or >
# It's called by serialize() if $WDDX::INDENT is defined
sub _xml_indent {
    my $xml = shift;
    my $indent = $WDDX::INDENT;
    my $level = 0;

    # It ain't pretty but it works...
    $xml =~ s{ (>?)\s*(< ([?!/]?) [^>/]* (/?) ) }{
# print "Matched: $&\n      1: $1\n      2: $2\n      3: $3\n      4: $4\n";
                $level-- if $3 eq "/" && not $4;
                my $result = $1 ? "$1\n" . ( $indent x $level ) . $2 : $2;
                $level++ unless $3 || $4;
                $result;
             }egx;
    return $xml;
}

__END__