view release on metacpan or  search on metacpan

lib/Frontier/RPC2.pm  view on Meta::CPAN

###
### XML::Parser callbacks
###

sub die {
    my $expat = shift; my $message = shift;

    die $message
	. "at line " . $expat->current_line
        . " column " . $expat->current_column . "\n";
}

sub init {
    my $expat = shift;

    $expat->{'rpc_state'} = [];
    $expat->{'rpc_container'} = [ [] ];
    $expat->{'rpc_member_name'} = [];
    $expat->{'rpc_type'} = undef;
    $expat->{'rpc_args'} = undef;
}

# FIXME this state machine wouldn't be necessary if we had a DTD.
sub start {
    my $expat = shift; my $tag = shift;

    my $state = $expat->{'rpc_state'}[-1];

    if (!defined $state) {
	if ($tag eq 'methodCall') {
	    $expat->{'rpc_type'} = 'call';
	    push @{ $expat->{'rpc_state'} }, 'want_method_name';
	} elsif ($tag eq 'methodResponse') {
	    push @{ $expat->{'rpc_state'} }, 'method_response';
	} else {
	    Frontier::RPC2::die($expat, "unknown RPC type \`$tag'\n");
	}
    } elsif ($state eq 'want_method_name') {
	Frontier::RPC2::die($expat, "wanted \`methodName' tag, got \`$tag'\n")
	    if ($tag ne 'methodName');
	push @{ $expat->{'rpc_state'} }, 'method_name';
	$expat->{'rpc_text'} = "";
    } elsif ($state eq 'method_response') {
	if ($tag eq 'params') {
	    $expat->{'rpc_type'} = 'response';
	    push @{ $expat->{'rpc_state'} }, 'params';
	} elsif ($tag eq 'fault') {
	    $expat->{'rpc_type'} = 'fault';
	    push @{ $expat->{'rpc_state'} }, 'want_value';
	}
    } elsif ($state eq 'want_params') {
	Frontier::RPC2::die($expat, "wanted \`params' tag, got \`$tag'\n")
	    if ($tag ne 'params');
	push @{ $expat->{'rpc_state'} }, 'params';
    } elsif ($state eq 'params') {
	Frontier::RPC2::die($expat, "wanted \`param' tag, got \`$tag'\n")
	    if ($tag ne 'param');
	push @{ $expat->{'rpc_state'} }, 'want_param_name_or_value';
    } elsif ($state eq 'want_param_name_or_value') {
	if ($tag eq 'value') {
	    $expat->{'may_get_cdata'} = 1;
	    $expat->{'rpc_text'} = "";
	    push @{ $expat->{'rpc_state'} }, 'value';
	} elsif ($tag eq 'name') {
	    push @{ $expat->{'rpc_state'} }, 'param_name';
	} else {	    
	    Frontier::RPC2::die($expat, "wanted \`value' or \`name' tag, got \`$tag'\n");
	}
    } elsif ($state eq 'param_name') {
	Frontier::RPC2::die($expat, "wanted parameter name data, got tag \`$tag'\n");
    } elsif ($state eq 'want_value') {
	Frontier::RPC2::die($expat, "wanted \`value' tag, got \`$tag'\n")
	    if ($tag ne 'value');
	$expat->{'rpc_text'} = "";
	$expat->{'may_get_cdata'} = 1;
	push @{ $expat->{'rpc_state'} }, 'value';
    } elsif ($state eq 'value') {
	$expat->{'may_get_cdata'} = 0;
	if ($tag eq 'array') {
	    push @{ $expat->{'rpc_container'} }, [];
	    push @{ $expat->{'rpc_state'} }, 'want_data';
	} elsif ($tag eq 'struct') {
	    push @{ $expat->{'rpc_container'} }, {};
	    push @{ $expat->{'rpc_member_name'} }, undef;
	    push @{ $expat->{'rpc_state'} }, 'struct';
	} elsif ($scalars{$tag}) {
	    $expat->{'rpc_text'} = "";
	    push @{ $expat->{'rpc_state'} }, 'cdata';
	} else {
	    Frontier::RPC2::die($expat, "wanted a data type, got \`$tag'\n");
	}
    } elsif ($state eq 'want_data') {
	Frontier::RPC2::die($expat, "wanted \`data', got \`$tag'\n")
	    if ($tag ne 'data');
	push @{ $expat->{'rpc_state'} }, 'array';
    } elsif ($state eq 'array') {
	Frontier::RPC2::die($expat, "wanted \`value' tag, got \`$tag'\n")
	    if ($tag ne 'value');
	$expat->{'rpc_text'} = "";
	$expat->{'may_get_cdata'} = 1;
	push @{ $expat->{'rpc_state'} }, 'value';
    } elsif ($state eq 'struct') {
	Frontier::RPC2::die($expat, "wanted \`member' tag, got \`$tag'\n")
	    if ($tag ne 'member');
	push @{ $expat->{'rpc_state'} }, 'want_member_name';
    } elsif ($state eq 'want_member_name') {
	Frontier::RPC2::die($expat, "wanted \`name' tag, got \`$tag'\n")
	    if ($tag ne 'name');
	push @{ $expat->{'rpc_state'} }, 'member_name';
	$expat->{'rpc_text'} = "";
    } elsif ($state eq 'member_name') {
	Frontier::RPC2::die($expat, "wanted data, got tag \`$tag'\n");
    } elsif ($state eq 'cdata') {
	Frontier::RPC2::die($expat, "wanted data, got tag \`$tag'\n");
    } else {
	Frontier::RPC2::die($expat, "internal error, unknown state \`$state'\n");
    }
}

sub end {
    my $expat = shift; my $tag = shift;

    my $state = pop @{ $expat->{'rpc_state'} };

    if ($state eq 'cdata') {
	my $value = $expat->{'rpc_text'};
	if ($tag eq 'base64') {
	    $value = Frontier::RPC2::Base64->new($value);
	} elsif ($tag eq 'boolean') {
	    $value = Frontier::RPC2::Boolean->new($value);
	} elsif ($tag eq 'dateTime.iso8601') {
	    $value = Frontier::RPC2::DateTime::ISO8601->new($value);
	} elsif ($expat->{'use_objects'}) {
	    if ($tag eq 'i4' or $tag eq 'int') {
		$value = Frontier::RPC2::Integer->new($value);
	    } elsif ($tag eq 'float') {
		$value = Frontier::RPC2::Float->new($value);
	    } elsif ($tag eq 'string') {
		$value = Frontier::RPC2::String->new($value);
	    }
	}
	$expat->{'rpc_value'} = $value;
    } elsif ($state eq 'member_name') {
	$expat->{'rpc_member_name'}[-1] = $expat->{'rpc_text'};
	$expat->{'rpc_state'}[-1] = 'want_value';
    } elsif ($state eq 'method_name') {
	$expat->{'rpc_method_name'} = $expat->{'rpc_text'};
	$expat->{'rpc_state'}[-1] = 'want_params';
    } elsif ($state eq 'struct') {
	$expat->{'rpc_value'} = pop @{ $expat->{'rpc_container'} };
	pop @{ $expat->{'rpc_member_name'} };
    } elsif ($state eq 'array') {
	$expat->{'rpc_value'} = pop @{ $expat->{'rpc_container'} };
    } elsif ($state eq 'value') {
	# the rpc_text is a string if no type tags were given
	if ($expat->{'may_get_cdata'}) {
	    $expat->{'may_get_cdata'} = 0;
	    if ($expat->{'use_objects'}) {
		$expat->{'rpc_value'}
		= Frontier::RPC2::String->new($expat->{'rpc_text'});
	    } else {
		$expat->{'rpc_value'} = $expat->{'rpc_text'};
	    }
	}
	my $container = $expat->{'rpc_container'}[-1];
	if (ref($container) eq 'ARRAY') {
	    push @$container, $expat->{'rpc_value'};
	} elsif (ref($container) eq 'HASH') {
	    $container->{ $expat->{'rpc_member_name'}[-1] } = $expat->{'rpc_value'};
	}
    }
}

sub char {
    my $expat = shift; my $text = shift;

    $expat->{'rpc_text'} .= $text;
}

sub proc {
}

sub final {
    my $expat = shift;

    $expat->{'rpc_value'} = pop @{ $expat->{'rpc_container'} };
    
    return {
	value => $expat->{'rpc_value'},
	type => $expat->{'rpc_type'},
	method_name => $expat->{'rpc_method_name'},
    };
}

package Frontier::RPC2::DataType;

sub new {
    my $type = shift; my $value = shift;

    return bless \$value, $type;
}

# `repr' returns the XML representation of this data, which may be
# different [in the future] from what is returned from `value'
sub repr {
    my $self = shift;

    return $$self;
}

# sets or returns the usable value of this data
sub value {
    my $self = shift;
    @_ ? ($$self = shift) : $$self;
}

package Frontier::RPC2::Base64;