From 12208c1650c35e07f5da708614c45b48aa798192 Mon Sep 17 00:00:00 2001 From: miker Date: Mon, 14 Feb 2005 17:42:53 +0000 Subject: [PATCH] started introspection API; added thunking flag; added "atomic-ifier" and stream flag to registration; repurposed "protocol" to be "api_level" git-svn-id: svn://svn.open-ils.org/OpenSRF/trunk@48 9efc2488-bf62-4759-914b-345cdb29e865 --- src/perlmods/OpenSRF/AppSession.pm | 21 +++-- src/perlmods/OpenSRF/Application.pm | 97 ++++++++++++++++++++---- src/perlmods/OpenSRF/DomainObject/oilsMessage.pm | 22 +++--- 3 files changed, 102 insertions(+), 38 deletions(-) diff --git a/src/perlmods/OpenSRF/AppSession.pm b/src/perlmods/OpenSRF/AppSession.pm index 8aa275f..d97ac84 100644 --- a/src/perlmods/OpenSRF/AppSession.pm +++ b/src/perlmods/OpenSRF/AppSession.pm @@ -55,8 +55,7 @@ sub find_client { 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(); @@ -174,7 +173,7 @@ sub create { $class = ref($class) || $class; my $app = shift; - my %auth_args = @_; + #my %auth_args = @_; # unless ( $app && @@ -405,7 +404,7 @@ sub send { } } - $msg->protocol(1); + $msg->api_level(1); $msg->payload($payload) if $payload; $doc->documentElement->appendChild( $msg ); @@ -517,17 +516,17 @@ sub last_message_type { 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 { diff --git a/src/perlmods/OpenSRF/Application.pm b/src/perlmods/OpenSRF/Application.pm index 448fd5d..3b0889a 100644 --- a/src/perlmods/OpenSRF/Application.pm +++ b/src/perlmods/OpenSRF/Application.pm @@ -1,4 +1,6 @@ package OpenSRF::Application; +use vars qw/$_app $log @_METHODS $thunk//; + use base qw/OpenSRF/; use OpenSRF::AppSession; use OpenSRF::DomainObject::oilsMethod; @@ -6,8 +8,9 @@ use OpenSRF::DomainObject::oilsResponse qw/:status/; 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; @@ -16,6 +19,13 @@ $log = 'OpenSRF::Utils::Logger'; 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; @@ -55,7 +65,7 @@ sub handler { 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 ); @@ -176,7 +186,7 @@ sub handler { } $session->last_message_type(''); - $session->last_message_protocol(''); + $session->last_message_api_level(''); return 1; } @@ -186,34 +196,58 @@ sub register_method { 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 { @@ -243,4 +277,35 @@ 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; diff --git a/src/perlmods/OpenSRF/DomainObject/oilsMessage.pm b/src/perlmods/OpenSRF/DomainObject/oilsMessage.pm index 268141c..facc5dc 100644 --- a/src/perlmods/OpenSRF/DomainObject/oilsMessage.pm +++ b/src/perlmods/OpenSRF/DomainObject/oilsMessage.pm @@ -49,11 +49,11 @@ sub type { 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. @@ -62,9 +62,9 @@ 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] ); @@ -175,14 +175,14 @@ sub handler { 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); @@ -191,10 +191,10 @@ sub handler { 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 ) { @@ -211,7 +211,7 @@ sub handler { # !!! 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 @@ -283,7 +283,7 @@ sub do_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') { -- 2.11.0