sub transport_connected {
my $self = shift;
- if( ! exists $self->{peer_handle} ||
- ! $self->{peer_handle} ) {
+ if( ! exists $self->{peer_handle} || ! $self->{peer_handle} ) {
return 0;
}
return $self->{peer_handle}->tcp_connected();
$class = ref($class) || $class;
my $app = shift;
- my %auth_args = @_;
+ #my %auth_args = @_;
# unless ( $app &&
}
}
- $msg->protocol(1);
+ $msg->api_level(1);
$msg->payload($payload) if $payload;
$doc->documentElement->appendChild( $msg );
return $old_last_message_type;
}
-sub last_message_protocol {
+sub last_message_api_level {
my $self = shift;
- my $new_last_message_protocol = shift;
+ my $new_last_message_api_level = shift;
- my $old_last_message_protocol = $self->{last_message_protocol};
- if (defined $new_last_message_protocol) {
- $self->{last_message_protocol} = $new_last_message_protocol;
- return $new_last_message_protocol unless ($old_last_message_protocol);
+ my $old_last_message_api_level = $self->{last_message_api_level};
+ if (defined $new_last_message_api_level) {
+ $self->{last_message_api_level} = $new_last_message_api_level;
+ return $new_last_message_api_level unless ($old_last_message_api_level);
}
- return $old_last_message_protocol;
+ return $old_last_message_api_level;
}
sub remote_id {
package OpenSRF::Application;
+use vars qw/$_app $log @_METHODS $thunk//;
+
use base qw/OpenSRF/;
use OpenSRF::AppSession;
use OpenSRF::DomainObject::oilsMethod;
use OpenSRF::Utils::Logger qw/:level/;
use Data::Dumper;
use Time::HiRes qw/time/;
-use vars qw/$_app $log %_METHODS/;
use OpenSRF::EX qw/:try/;
+use OpenSRF::UnixServer; # to get the server class from UnixServer::App
+
use strict;
use warnings;
our $in_request = 0;
our @pending_requests;
+sub thunk {
+ my $self = shift;
+ my $flag = shift;
+ $thunk = $flag if (defined $flag);
+ return $thunk;
+}
+
sub application_implementation {
my $self = shift;
my $app = shift;
my $method_name = $app_msg->method;
$log->debug( " * Looking up $method_name inside $app", DEBUG);
- my $method_proto = $session->last_message_protocol;
+ my $method_proto = $session->last_message_api_level;
$log->debug( " * Method API Level [$method_proto]", DEBUG);
my $coderef = $app->method_lookup( $method_name, $method_proto );
}
$session->last_message_type('');
- $session->last_message_protocol('');
+ $session->last_message_api_level('');
return 1;
}
my $app = ref($self) || $self;
my %args = @_;
+
throw OpenSRF::DomainObject::oilsMethodException unless ($args{method});
-
- $args{protocol} ||= 1;
- $args{api_name} ||= $app . '.' . $args{method};
+
+ $args{api_level} ||= 1;
+ $args{stream} ||= 0;
+ $args{package} ||= $app;
+ $args{api_name} ||= UnixServer->app() . '.' . $args{method};
$args{code} ||= \&{$app . '::' . $args{method}};
-
- $_METHODS{$args{api_name}} = bless \%args => $app;
+
+ $_METHODS[$args{api_level}]{$args{api_name}} = bless \%args => $app;
+
+ __PACKAGE__->register_method(
+ stream => 0,
+ api_name => $args{api_name}.'.atomic',
+ method => 'make_stream_atomic'
+ ) if ($stream);
}
sub method_lookup {
my $self = shift;
my $method = shift;
- my $proto = shift || 1;
+ my $proto = shift;
+
+ # this instead of " || 1;" above to allow api_level 0
+ $proto = 1 unless (defined $proto);
my $class = ref($self) || $self;
- $log->debug("Specialized lookup of [$method] in [$class]", DEBUG);
+ $log->debug("Lookup of [$method] by [$class]", DEBUG);
$log->debug("Available methods\n".Dumper(\%_METHODS), INTERNAL);
- if (exists $_METHODS{$method}) {
- $log->debug("Looks like we found [$method]", DEBUG);
- my $meth = $_METHODS{$method} if ($_METHODS{$method}{protocol} == $proto);
+ my $meth;
+ if (__PACKAGE__->thunk) {
+ for my $p ( reverse(1 .. $proto) ) {
+ if (exists $_METHODS[$p]{$method}) {
+ $meth = $_METHODS[$p]{$method};
+ }
+ }
+ } else {
+ if (exists $_METHODS[$proto]{$method}) {
+ $meth = $_METHODS[$proto]{$method};
+ }
+ }
+
+ if (defined $meth) {
+ $log->debug("Looks like we found [$method]!", DEBUG);
$log->debug("Method object is ".Dumper($meth), INTERNAL);
- return $meth;
- }
+ }
+
+ return $meth;
- return undef;
}
sub run {
return $resp;
}
+sub introspect {
+ my $self = shift;
+ my $client = shift;
+
+ for my $api_level ( 1 .. $#_METHODS ) {
+ $client->respond( $_METHODS[$api_level] );
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ stream => 1,
+ method => 'introspect',
+ api_name => 'opensrf.system.method_list'
+);
+
+sub make_stream_atomic {
+ my $self = shift;
+ my $req = shift;
+ my @args = @_;
+
+ (my $m_name = $self->api_name) =~ s/\.atomic$//o;
+ my @results = $self->method_lookup($m_name)->run(@args);
+
+ if (@results == 1) {
+ return $results[0];
+ }
+ return \@results;
+}
+
+
1;
return $self->_attr_get_set( type => shift );
}
-=head2 OpenSRF::DomainObject::oilsMessage->protocol( [$new_protocol_number] )
+=head2 OpenSRF::DomainObject::oilsMessage->api_level( [$new_api_level] )
=over 4
-Used to specify the protocol of message. Currently, only protocol C<1> is
+Used to specify the api_level of message. Currently, only api_level C<1> is
supported. This will be used to check that messages are well-formed, and as
a hint to the Application as to which version of a method should fulfill a
REQUEST message.
=cut
-sub protocol {
+sub api_level {
my $self = shift;
- return $self->_attr_get_set( protocol => shift );
+ return $self->_attr_get_set( api_level => shift );
}
=head2 OpenSRF::DomainObject::oilsMessage->threadTrace( [$new_threadTrace] );
my $session = shift;
my $mtype = $self->type;
- my $protocol = $self->protocol || 1;;
+ my $api_level = $self->api_level || 1;;
my $tT = $self->threadTrace;
$session->last_message_type($mtype);
- $session->last_message_protocol($protocol);
+ $session->last_message_api_level($api_level);
$session->last_threadTrace($tT);
- $log->debug(" Received protocol => [$protocol], MType => [$mtype], ".
+ $log->debug(" Received api_level => [$api_level], MType => [$mtype], ".
"from [".$session->remote_id."], threadTrace[".$self->threadTrace."]", INFO);
$log->debug("endpoint => [".$session->endpoint."]", DEBUG);
$log->debug("OpenSRF::AppSession->SERVER => [".$session->SERVER()."]", DEBUG);
my $val;
if ( $session->endpoint == $session->SERVER() ) {
- $val = $self->do_server( $session, $mtype, $protocol, $tT );
+ $val = $self->do_server( $session, $mtype, $api_level, $tT );
} elsif ($session->endpoint == $session->CLIENT()) {
- $val = $self->do_client( $session, $mtype, $protocol, $tT );
+ $val = $self->do_client( $session, $mtype, $api_level, $tT );
}
if( $val ) {
# !!! Returning 0 means that we don't want to pass ourselves up to the message layer !!!
sub do_server {
- my( $self, $session, $mtype, $protocol, $tT ) = @_;
+ my( $self, $session, $mtype, $api_level, $tT ) = @_;
# A Server should never receive STATUS messages. If so, we drop them.
# This is to keep STATUS's from dead client sessions from creating new server
# up to the application layer. return 0 otherwise.
sub do_client {
- my( $self, $session , $mtype, $protocol, $tT) = @_;
+ my( $self, $session , $mtype, $api_level, $tT) = @_;
if ($mtype eq 'STATUS') {
projects / opensrf / bjwebb.git / commitdiff