merging perl CPANification/normalization branch work
authorsboyette <sboyette@9efc2488-bf62-4759-914b-345cdb29e865>
Mon, 18 Aug 2008 19:14:00 +0000 (19:14 +0000)
committersboyette <sboyette@9efc2488-bf62-4759-914b-345cdb29e865>
Mon, 18 Aug 2008 19:14:00 +0000 (19:14 +0000)
git-svn-id: svn://svn.open-ils.org/OpenSRF/trunk@1418 9efc2488-bf62-4759-914b-345cdb29e865

89 files changed:
Makefile.am
src/Makefile.am
src/gateway/Makefile.am
src/perl/Changes [new file with mode: 0644]
src/perl/MANIFEST [new file with mode: 0644]
src/perl/Makefile.PL [new file with mode: 0644]
src/perl/README [new file with mode: 0644]
src/perl/inc/Module/Install.pm [new file with mode: 0644]
src/perl/inc/Module/Install/Base.pm [new file with mode: 0644]
src/perl/inc/Module/Install/Can.pm [new file with mode: 0644]
src/perl/inc/Module/Install/Fetch.pm [new file with mode: 0644]
src/perl/inc/Module/Install/Makefile.pm [new file with mode: 0644]
src/perl/inc/Module/Install/Metadata.pm [new file with mode: 0644]
src/perl/inc/Module/Install/Win32.pm [new file with mode: 0644]
src/perl/inc/Module/Install/WriteAll.pm [new file with mode: 0644]
src/perl/lib/OpenSRF.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/AppSession.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/Application.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/Application/Client.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/Application/Demo/Math.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/Application/Demo/MathDB.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/Application/Persist.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/Application/Settings.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/DomainObject/oilsMessage.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/DomainObject/oilsMethod.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/DomainObject/oilsResponse.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/EX.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/MultiSession.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/System.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/Transport.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/Transport/Listener.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/Transport/PeerHandle.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/Transport/SlimJabber.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/Transport/SlimJabber/Client.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/Transport/SlimJabber/Inbound.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/Transport/SlimJabber/MessageWrapper.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/Transport/SlimJabber/PeerConnection.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/Transport/SlimJabber/XMPPMessage.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/Transport/SlimJabber/XMPPReader.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/UnixServer.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/Utils.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/Utils/Cache.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/Utils/Config.pm [new file with mode: 0755]
src/perl/lib/OpenSRF/Utils/JSON.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/Utils/LogServer.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/Utils/Logger.pm [new file with mode: 0644]
src/perl/lib/OpenSRF/Utils/SettingsClient.pm [new file with mode: 0755]
src/perl/lib/OpenSRF/Utils/SettingsParser.pm [new file with mode: 0755]
src/perl/t/00-load.t [new file with mode: 0644]
src/perl/t/pod-coverage.t [new file with mode: 0644]
src/perl/t/pod.t [new file with mode: 0644]
src/perlmods/OpenSRF.pm [deleted file]
src/perlmods/OpenSRF/AppSession.pm [deleted file]
src/perlmods/OpenSRF/Application.pm [deleted file]
src/perlmods/OpenSRF/Application/Client.pm [deleted file]
src/perlmods/OpenSRF/Application/Demo/Math.pm [deleted file]
src/perlmods/OpenSRF/Application/Demo/MathDB.pm [deleted file]
src/perlmods/OpenSRF/Application/Persist.pm [deleted file]
src/perlmods/OpenSRF/Application/Settings.pm [deleted file]
src/perlmods/OpenSRF/DomainObject/oilsMessage.pm [deleted file]
src/perlmods/OpenSRF/DomainObject/oilsMethod.pm [deleted file]
src/perlmods/OpenSRF/DomainObject/oilsResponse.pm [deleted file]
src/perlmods/OpenSRF/EX.pm [deleted file]
src/perlmods/OpenSRF/MultiSession.pm [deleted file]
src/perlmods/OpenSRF/System.pm [deleted file]
src/perlmods/OpenSRF/Transport.pm [deleted file]
src/perlmods/OpenSRF/Transport/Jabber.pm [deleted file]
src/perlmods/OpenSRF/Transport/Jabber/JInbound.pm [deleted file]
src/perlmods/OpenSRF/Transport/Jabber/JMessageWrapper.pm [deleted file]
src/perlmods/OpenSRF/Transport/Jabber/JPeerConnection.pm [deleted file]
src/perlmods/OpenSRF/Transport/Jabber/JabberClient.pm [deleted file]
src/perlmods/OpenSRF/Transport/Listener.pm [deleted file]
src/perlmods/OpenSRF/Transport/PeerHandle.pm [deleted file]
src/perlmods/OpenSRF/Transport/SlimJabber.pm [deleted file]
src/perlmods/OpenSRF/Transport/SlimJabber/Client.pm [deleted file]
src/perlmods/OpenSRF/Transport/SlimJabber/Inbound.pm [deleted file]
src/perlmods/OpenSRF/Transport/SlimJabber/MessageWrapper.pm [deleted file]
src/perlmods/OpenSRF/Transport/SlimJabber/PeerConnection.pm [deleted file]
src/perlmods/OpenSRF/Transport/SlimJabber/XMPPMessage.pm [deleted file]
src/perlmods/OpenSRF/Transport/SlimJabber/XMPPReader.pm [deleted file]
src/perlmods/OpenSRF/UnixServer.pm [deleted file]
src/perlmods/OpenSRF/Utils.pm [deleted file]
src/perlmods/OpenSRF/Utils/Cache.pm [deleted file]
src/perlmods/OpenSRF/Utils/Config.pm [deleted file]
src/perlmods/OpenSRF/Utils/JSON.pm [deleted file]
src/perlmods/OpenSRF/Utils/LogServer.pm [deleted file]
src/perlmods/OpenSRF/Utils/Logger.pm [deleted file]
src/perlmods/OpenSRF/Utils/SettingsClient.pm [deleted file]
src/perlmods/OpenSRF/Utils/SettingsParser.pm [deleted file]

index 8d1b133..bf334d2 100644 (file)
@@ -70,7 +70,7 @@ libosrf_FILES = @srcdir@/src/libopensrf/basic_client.c \
                @srcdir@/src/libopensrf/osrfConfig.c
 
 
-EXTRA_DIST = $(DOC_FILES) $(EXAMPLES_FILES) $(libosrf_FILES) $(strn_compat_FILES) $(python_FILES) $(java_FILES) @srcdir@/autogen.sh @srcdir@/src/extras @srcdir@/DCO-1.1.txt @srcdir@/LICENSE.txt @srcdir@/src/perlmods @srcdir@/src/javascript
+EXTRA_DIST = $(DOC_FILES) $(EXAMPLES_FILES) $(libosrf_FILES) $(strn_compat_FILES) $(python_FILES) $(java_FILES) @srcdir@/autogen.sh @srcdir@/src/extras @srcdir@/DCO-1.1.txt @srcdir@/LICENSE.txt @srcdir@/src/perl @srcdir@/src/javascript
 
 opensrfincludedir = @includedir@/opensrf
 
index c32950b..c7f0cfd 100644 (file)
@@ -17,7 +17,6 @@
 export OPENSRF = opensrf
 export BINDIR  = @bindir@
 export LIBDIR  = @libdir@
-perldir        = $(LIBDIR)/perl5
 jsdir = $(LIBDIR)/javascript
 export OSRF_JAVA_DEPSDIR = @OSRF_JAVA_DEPSDIR@
 etcdir = $(ETCDIR)
@@ -47,7 +46,7 @@ install-exec-local:
        mkdir -p $(LOG)
        mkdir -p $(SOCK)
        mkdir -p $(jsdir)
-       mkdir -p $(perldir)
+       make install-perl
 
 install-exec-hook:
        sed -i 's|LOCALSTATEDIR|$(VAR)|g' '$(DESTDIR)@sysconfdir@/opensrf.xml.example'
@@ -60,12 +59,24 @@ install-exec-hook:
        sed -i 's|LIBDIR|$(LIBDIR)|g' '@abs_top_srcdir@/examples/multisession-test.pl'
        sed -i 's|SYSCONFDIR|$(ETCDIR)|g' '@abs_top_srcdir@/doc/dokuwiki-doc-stubber.pl'
        cp -r @srcdir@/javascript/* $(jsdir)/
-       sed -i 's|LOCALSTATEDIR|$(VAR)|g' '@srcdir@/perlmods/OpenSRF/Utils/Config.pm'
-       cp -r @srcdir@/perlmods/* $(perldir)/
 
 
+install-perl:
+       cd ./perl && perl Makefile.PL || make -s install-perl-fail
+       make -C perl
+       make -C perl test || make -s install-perl-fail
+       make -C perl install
+
+install-perl-fail:
+       echo
+       echo ">>> Installation of Perl modules has failed. The most likely"
+       echo ">>> possibility is that a dependency is not pre-installed"
+       echo ">>> or that a test has failed."
+       echo ">>> See the messages above this one for more information."
+       echo
+       exit 1
+
 uninstall-hook:
        rm @includedir@/opensrf/apachetools.h
        rm -R $(jsdir)
-       rm -R $(perldir)
 
index f345a00..3fba17c 100644 (file)
@@ -18,6 +18,10 @@ AM_CFLAGS = -D_LARGEFILE64_SOURCE -Wall -I@abs_top_srcdir@/include/ -I$(LIBXML2_
 AM_LDFLAGS = -L$(LIBDIR) -L@top_builddir@/src/libopensrf
 
 install-exec-local: 
+       if [ ! "$$(grep mod_placeholder `apxs2 -q SYSCONFDIR`/httpd.conf)" ]; \
+               then echo -e "#\n#LoadModule mod_placeholder /usr/lib/apache2/modules/mod_placeholder.so" \
+               >> `apxs2 -q SYSCONFDIR`/httpd.conf; \
+       fi
        $(APXS2) -c $(DEF_LDLIBS) $(AM_CFLAGS) $(AM_LDFLAGS) @srcdir@/osrf_json_gateway.c apachetools.c apachetools.h libopensrf.so
        $(APXS2) -c $(DEF_LDLIBS) $(AM_CFLAGS) $(AM_LDFLAGS) @srcdir@/osrf_http_translator.c apachetools.c apachetools.h libopensrf.so
        $(APXS2) -i -a @srcdir@/osrf_json_gateway.la
diff --git a/src/perl/Changes b/src/perl/Changes
new file mode 100644 (file)
index 0000000..c12049f
--- /dev/null
@@ -0,0 +1,5 @@
+Revision history for OpenSRF
+
+0.9     2006/07
+        First version, released on an unsuspecting world.
+
diff --git a/src/perl/MANIFEST b/src/perl/MANIFEST
new file mode 100644 (file)
index 0000000..931f8b0
--- /dev/null
@@ -0,0 +1,40 @@
+Changes
+MANIFEST
+Makefile.PL
+README
+lib/OpenSRF.pm
+lib/OpenSRF/Application.pm
+lib/OpenSRF/Application/Client.pm
+lib/OpenSRF/Application/Persist.pm
+lib/OpenSRF/Application/Settings.pm
+lib/OpenSRF/Application/Demo/Math.pm
+lib/OpenSRF/Application/Demo/MathDB.pm
+lib/OpenSRF/AppSession.pm
+lib/OpenSRF/DomainObject/oilsMessage.pm
+lib/OpenSRF/DomainObject/oilsMethod.pm
+lib/OpenSRF/DomainObject/oilsResponse.pm
+lib/OpenSRF/EX.pm
+lib/OpenSRF/MultiSession.pm
+lib/OpenSRF/System.pm
+lib/OpenSRF/Transport.pm
+lib/OpenSRF/Transport/Listener.pm
+lib/OpenSRF/Transport/PeerHandle.pm
+lib/OpenSRF/Transport/SlimJabber.pm
+lib/OpenSRF/Transport/SlimJabber/Client.pm
+lib/OpenSRF/Transport/SlimJabber/Inbound.pm
+lib/OpenSRF/Transport/SlimJabber/MessageWrapper.pm
+lib/OpenSRF/Transport/SlimJabber/PeerConnection.pm
+lib/OpenSRF/Transport/SlimJabber/XMPPMessage.pm
+lib/OpenSRF/Transport/SlimJabber/XMPPReader.pm
+lib/OpenSRF/UnixServer.pm
+lib/OpenSRF/Utils.pm
+lib/OpenSRF/Utils/Cache.pm
+lib/OpenSRF/Utils/Config.pm
+lib/OpenSRF/Utils/JSON.pm
+lib/OpenSRF/Utils/Logger.pm
+lib/OpenSRF/Utils/LogServer.pm
+lib/OpenSRF/Utils/SettingsClient.pm
+lib/OpenSRF/Utils/SettingsParser.pm
+t/00-load.t
+t/pod-coverage.t
+t/pod.t
diff --git a/src/perl/Makefile.PL b/src/perl/Makefile.PL
new file mode 100644 (file)
index 0000000..55d5127
--- /dev/null
@@ -0,0 +1,26 @@
+use inc::Module::Install;
+
+# Define metadata
+name           'OpenSRF';
+all_from       'lib/OpenSRF.pm';
+license        'perl';
+
+# Specific dependencies
+requires 'Cache::Memcached' => 0;
+requires 'Data::Dumper'     => 0;
+requires 'DateTime'         => 0;
+requires 'DBI'              => 0;
+requires 'Digest::MD5'      => 0;
+requires 'Errno'            => 0;
+requires 'Error'            => 0;
+requires 'FreezeThaw'       => 0;
+requires 'IO'               => 0;
+requires 'JSON'             => 0;
+requires 'Net::Domain'      => 0;
+requires 'Net::Server'      => 0;
+requires 'Time::HiRes'      => 0;
+requires 'Time::Local'      => 0;
+requires 'UNIVERSAL::require' => 0;
+requires 'XML::LibXML'        => 0;
+
+WriteAll;
diff --git a/src/perl/README b/src/perl/README
new file mode 100644 (file)
index 0000000..b7015e5
--- /dev/null
@@ -0,0 +1,33 @@
+OpenSRF
+
+OpenSRF (Open OpenSRF (Open Scalable Request Framework) is a core
+subsystem of the Evergreen ILS.
+
+INSTALLATION
+
+To install this module, run the following commands:
+
+       perl Makefile.PL
+       make
+       make test
+       make install
+
+SUPPORT AND DOCUMENTATION
+
+After installing, you can find documentation for this module with the
+perldoc command.
+
+    perldoc OpenSRF
+
+You can also look for information at:
+
+    http://svn.open-ils.org/trac/OpenSRF
+
+
+COPYRIGHT AND LICENCE
+
+Copyright (C) 2008 Equinox Software, Inc.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
diff --git a/src/perl/inc/Module/Install.pm b/src/perl/inc/Module/Install.pm
new file mode 100644 (file)
index 0000000..87bed66
--- /dev/null
@@ -0,0 +1,364 @@
+#line 1
+package Module::Install;
+
+# For any maintainers:
+# The load order for Module::Install is a bit magic.
+# It goes something like this...
+#
+# IF ( host has Module::Install installed, creating author mode ) {
+#     1. Makefile.PL calls "use inc::Module::Install"
+#     2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
+#     3. The installed version of inc::Module::Install loads
+#     4. inc::Module::Install calls "require Module::Install"
+#     5. The ./inc/ version of Module::Install loads
+# } ELSE {
+#     1. Makefile.PL calls "use inc::Module::Install"
+#     2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
+#     3. The ./inc/ version of Module::Install loads
+# }
+
+BEGIN {
+       require 5.004;
+}
+use strict 'vars';
+
+use vars qw{$VERSION};
+BEGIN {
+       # All Module::Install core packages now require synchronised versions.
+       # This will be used to ensure we don't accidentally load old or
+       # different versions of modules.
+       # This is not enforced yet, but will be some time in the next few
+       # releases once we can make sure it won't clash with custom
+       # Module::Install extensions.
+       $VERSION = '0.76';
+
+       *inc::Module::Install::VERSION = *VERSION;
+       @inc::Module::Install::ISA     = __PACKAGE__;
+
+}
+
+
+
+
+
+# Whether or not inc::Module::Install is actually loaded, the
+# $INC{inc/Module/Install.pm} is what will still get set as long as
+# the caller loaded module this in the documented manner.
+# If not set, the caller may NOT have loaded the bundled version, and thus
+# they may not have a MI version that works with the Makefile.PL. This would
+# result in false errors or unexpected behaviour. And we don't want that.
+my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
+unless ( $INC{$file} ) { die <<"END_DIE" }
+
+Please invoke ${\__PACKAGE__} with:
+
+       use inc::${\__PACKAGE__};
+
+not:
+
+       use ${\__PACKAGE__};
+
+END_DIE
+
+
+
+
+
+# If the script that is loading Module::Install is from the future,
+# then make will detect this and cause it to re-run over and over
+# again. This is bad. Rather than taking action to touch it (which
+# is unreliable on some platforms and requires write permissions)
+# for now we should catch this and refuse to run.
+if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" }
+
+Your installer $0 has a modification time in the future.
+
+This is known to create infinite loops in make.
+
+Please correct this, then run $0 again.
+
+END_DIE
+
+
+
+
+
+# Build.PL was formerly supported, but no longer is due to excessive
+# difficulty in implementing every single feature twice.
+if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
+
+Module::Install no longer supports Build.PL.
+
+It was impossible to maintain duel backends, and has been deprecated.
+
+Please remove all Build.PL files and only use the Makefile.PL installer.
+
+END_DIE
+
+
+
+
+
+# To save some more typing in Module::Install installers, every...
+# use inc::Module::Install
+# ...also acts as an implicit use strict.
+$^H |= strict::bits(qw(refs subs vars));
+
+
+
+
+
+use Cwd        ();
+use File::Find ();
+use File::Path ();
+use FindBin;
+
+sub autoload {
+       my $self = shift;
+       my $who  = $self->_caller;
+       my $cwd  = Cwd::cwd();
+       my $sym  = "${who}::AUTOLOAD";
+       $sym->{$cwd} = sub {
+               my $pwd = Cwd::cwd();
+               if ( my $code = $sym->{$pwd} ) {
+                       # delegate back to parent dirs
+                       goto &$code unless $cwd eq $pwd;
+               }
+               $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
+               unshift @_, ( $self, $1 );
+               goto &{$self->can('call')} unless uc($1) eq $1;
+       };
+}
+
+sub import {
+       my $class = shift;
+       my $self  = $class->new(@_);
+       my $who   = $self->_caller;
+
+       unless ( -f $self->{file} ) {
+               require "$self->{path}/$self->{dispatch}.pm";
+               File::Path::mkpath("$self->{prefix}/$self->{author}");
+               $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
+               $self->{admin}->init;
+               @_ = ($class, _self => $self);
+               goto &{"$self->{name}::import"};
+       }
+
+       *{"${who}::AUTOLOAD"} = $self->autoload;
+       $self->preload;
+
+       # Unregister loader and worker packages so subdirs can use them again
+       delete $INC{"$self->{file}"};
+       delete $INC{"$self->{path}.pm"};
+
+       return 1;
+}
+
+sub preload {
+       my $self = shift;
+       unless ( $self->{extensions} ) {
+               $self->load_extensions(
+                       "$self->{prefix}/$self->{path}", $self
+               );
+       }
+
+       my @exts = @{$self->{extensions}};
+       unless ( @exts ) {
+               my $admin = $self->{admin};
+               @exts = $admin->load_all_extensions;
+       }
+
+       my %seen;
+       foreach my $obj ( @exts ) {
+               while (my ($method, $glob) = each %{ref($obj) . '::'}) {
+                       next unless $obj->can($method);
+                       next if $method =~ /^_/;
+                       next if $method eq uc($method);
+                       $seen{$method}++;
+               }
+       }
+
+       my $who = $self->_caller;
+       foreach my $name ( sort keys %seen ) {
+               *{"${who}::$name"} = sub {
+                       ${"${who}::AUTOLOAD"} = "${who}::$name";
+                       goto &{"${who}::AUTOLOAD"};
+               };
+       }
+}
+
+sub new {
+       my ($class, %args) = @_;
+
+       # ignore the prefix on extension modules built from top level.
+       my $base_path = Cwd::abs_path($FindBin::Bin);
+       unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
+               delete $args{prefix};
+       }
+
+       return $args{_self} if $args{_self};
+
+       $args{dispatch} ||= 'Admin';
+       $args{prefix}   ||= 'inc';
+       $args{author}   ||= ($^O eq 'VMS' ? '_author' : '.author');
+       $args{bundle}   ||= 'inc/BUNDLES';
+       $args{base}     ||= $base_path;
+       $class =~ s/^\Q$args{prefix}\E:://;
+       $args{name}     ||= $class;
+       $args{version}  ||= $class->VERSION;
+       unless ( $args{path} ) {
+               $args{path}  = $args{name};
+               $args{path}  =~ s!::!/!g;
+       }
+       $args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";
+       $args{wrote}      = 0;
+
+       bless( \%args, $class );
+}
+
+sub call {
+       my ($self, $method) = @_;
+       my $obj = $self->load($method) or return;
+        splice(@_, 0, 2, $obj);
+       goto &{$obj->can($method)};
+}
+
+sub load {
+       my ($self, $method) = @_;
+
+       $self->load_extensions(
+               "$self->{prefix}/$self->{path}", $self
+       ) unless $self->{extensions};
+
+       foreach my $obj (@{$self->{extensions}}) {
+               return $obj if $obj->can($method);
+       }
+
+       my $admin = $self->{admin} or die <<"END_DIE";
+The '$method' method does not exist in the '$self->{prefix}' path!
+Please remove the '$self->{prefix}' directory and run $0 again to load it.
+END_DIE
+
+       my $obj = $admin->load($method, 1);
+       push @{$self->{extensions}}, $obj;
+
+       $obj;
+}
+
+sub load_extensions {
+       my ($self, $path, $top) = @_;
+
+       unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
+               unshift @INC, $self->{prefix};
+       }
+
+       foreach my $rv ( $self->find_extensions($path) ) {
+               my ($file, $pkg) = @{$rv};
+               next if $self->{pathnames}{$pkg};
+
+               local $@;
+               my $new = eval { require $file; $pkg->can('new') };
+               unless ( $new ) {
+                       warn $@ if $@;
+                       next;
+               }
+               $self->{pathnames}{$pkg} = delete $INC{$file};
+               push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
+       }
+
+       $self->{extensions} ||= [];
+}
+
+sub find_extensions {
+       my ($self, $path) = @_;
+
+       my @found;
+       File::Find::find( sub {
+               my $file = $File::Find::name;
+               return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
+               my $subpath = $1;
+               return if lc($subpath) eq lc($self->{dispatch});
+
+               $file = "$self->{path}/$subpath.pm";
+               my $pkg = "$self->{name}::$subpath";
+               $pkg =~ s!/!::!g;
+
+               # If we have a mixed-case package name, assume case has been preserved
+               # correctly.  Otherwise, root through the file to locate the case-preserved
+               # version of the package name.
+               if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
+                       my $content = Module::Install::_read($subpath . '.pm');
+                       my $in_pod  = 0;
+                       foreach ( split //, $content ) {
+                               $in_pod = 1 if /^=\w/;
+                               $in_pod = 0 if /^=cut/;
+                               next if ($in_pod || /^=cut/);  # skip pod text
+                               next if /^\s*#/;               # and comments
+                               if ( m/^\s*package\s+($pkg)\s*;/i ) {
+                                       $pkg = $1;
+                                       last;
+                               }
+                       }
+               }
+
+               push @found, [ $file, $pkg ];
+       }, $path ) if -d $path;
+
+       @found;
+}
+
+
+
+
+
+#####################################################################
+# Utility Functions
+
+sub _caller {
+       my $depth = 0;
+       my $call  = caller($depth);
+       while ( $call eq __PACKAGE__ ) {
+               $depth++;
+               $call = caller($depth);
+       }
+       return $call;
+}
+
+sub _read {
+       local *FH;
+       open FH, "< $_[0]" or die "open($_[0]): $!";
+       my $str = do { local $/; <FH> };
+       close FH or die "close($_[0]): $!";
+       return $str;
+}
+
+sub _write {
+       local *FH;
+       open FH, "> $_[0]" or die "open($_[0]): $!";
+       foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
+       close FH or die "close($_[0]): $!";
+}
+
+sub _version ($) {
+       my $s = shift || 0;
+          $s =~ s/^(\d+)\.?//;
+       my $l = $1 || 0;
+       my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
+          $l = $l . '.' . join '', @v if @v;
+       return $l + 0;
+}
+
+# Cloned from Params::Util::_CLASS
+sub _CLASS ($) {
+       (
+               defined $_[0]
+               and
+               ! ref $_[0]
+               and
+               $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s
+       ) ? $_[0] : undef;
+}
+
+1;
+
+# Copyright 2008 Adam Kennedy.
diff --git a/src/perl/inc/Module/Install/Base.pm b/src/perl/inc/Module/Install/Base.pm
new file mode 100644 (file)
index 0000000..76b32f8
--- /dev/null
@@ -0,0 +1,72 @@
+#line 1
+package Module::Install::Base;
+
+$VERSION = '0.76';
+
+# Suspend handler for "redefined" warnings
+BEGIN {
+       my $w = $SIG{__WARN__};
+       $SIG{__WARN__} = sub { $w };
+}
+
+### This is the ONLY module that shouldn't have strict on
+# use strict;
+
+#line 41
+
+sub new {
+    my ($class, %args) = @_;
+
+    foreach my $method ( qw(call load) ) {
+        *{"$class\::$method"} = sub {
+            shift()->_top->$method(@_);
+        } unless defined &{"$class\::$method"};
+    }
+
+    bless( \%args, $class );
+}
+
+#line 61
+
+sub AUTOLOAD {
+    my $self = shift;
+    local $@;
+    my $autoload = eval { $self->_top->autoload } or return;
+    goto &$autoload;
+}
+
+#line 76
+
+sub _top { $_[0]->{_top} }
+
+#line 89
+
+sub admin {
+    $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new;
+}
+
+#line 101
+
+sub is_admin {
+    $_[0]->admin->VERSION;
+}
+
+sub DESTROY {}
+
+package Module::Install::Base::FakeAdmin;
+
+my $Fake;
+sub new { $Fake ||= bless(\@_, $_[0]) }
+
+sub AUTOLOAD {}
+
+sub DESTROY {}
+
+# Restore warning handler
+BEGIN {
+       $SIG{__WARN__} = $SIG{__WARN__}->();
+}
+
+1;
+
+#line 146
diff --git a/src/perl/inc/Module/Install/Can.pm b/src/perl/inc/Module/Install/Can.pm
new file mode 100644 (file)
index 0000000..dd9a81c
--- /dev/null
@@ -0,0 +1,82 @@
+#line 1
+package Module::Install::Can;
+
+use strict;
+use Module::Install::Base;
+use Config ();
+### This adds a 5.005 Perl version dependency.
+### This is a bug and will be fixed.
+use File::Spec ();
+use ExtUtils::MakeMaker ();
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+       $VERSION = '0.76';
+       $ISCORE  = 1;
+       @ISA     = qw{Module::Install::Base};
+}
+
+# check if we can load some module
+### Upgrade this to not have to load the module if possible
+sub can_use {
+       my ($self, $mod, $ver) = @_;
+       $mod =~ s{::|\\}{/}g;
+       $mod .= '.pm' unless $mod =~ /\.pm$/i;
+
+       my $pkg = $mod;
+       $pkg =~ s{/}{::}g;
+       $pkg =~ s{\.pm$}{}i;
+
+       local $@;
+       eval { require $mod; $pkg->VERSION($ver || 0); 1 };
+}
+
+# check if we can run some command
+sub can_run {
+       my ($self, $cmd) = @_;
+
+       my $_cmd = $cmd;
+       return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
+
+       for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
+               my $abs = File::Spec->catfile($dir, $_[1]);
+               return $abs if (-x $abs or $abs = MM->maybe_command($abs));
+       }
+
+       return;
+}
+
+# can we locate a (the) C compiler
+sub can_cc {
+       my $self   = shift;
+       my @chunks = split(/ /, $Config::Config{cc}) or return;
+
+       # $Config{cc} may contain args; try to find out the program part
+       while (@chunks) {
+               return $self->can_run("@chunks") || (pop(@chunks), next);
+       }
+
+       return;
+}
+
+# Fix Cygwin bug on maybe_command();
+if ( $^O eq 'cygwin' ) {
+       require ExtUtils::MM_Cygwin;
+       require ExtUtils::MM_Win32;
+       if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) {
+               *ExtUtils::MM_Cygwin::maybe_command = sub {
+                       my ($self, $file) = @_;
+                       if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) {
+                               ExtUtils::MM_Win32->maybe_command($file);
+                       } else {
+                               ExtUtils::MM_Unix->maybe_command($file);
+                       }
+               }
+       }
+}
+
+1;
+
+__END__
+
+#line 157
diff --git a/src/perl/inc/Module/Install/Fetch.pm b/src/perl/inc/Module/Install/Fetch.pm
new file mode 100644 (file)
index 0000000..58df9ff
--- /dev/null
@@ -0,0 +1,93 @@
+#line 1
+package Module::Install::Fetch;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+       $VERSION = '0.76';
+       $ISCORE  = 1;
+       @ISA     = qw{Module::Install::Base};
+}
+
+sub get_file {
+    my ($self, %args) = @_;
+    my ($scheme, $host, $path, $file) = 
+        $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
+
+    if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
+        $args{url} = $args{ftp_url}
+            or (warn("LWP support unavailable!\n"), return);
+        ($scheme, $host, $path, $file) = 
+            $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
+    }
+
+    $|++;
+    print "Fetching '$file' from $host... ";
+
+    unless (eval { require Socket; Socket::inet_aton($host) }) {
+        warn "'$host' resolve failed!\n";
+        return;
+    }
+
+    return unless $scheme eq 'ftp' or $scheme eq 'http';
+
+    require Cwd;
+    my $dir = Cwd::getcwd();
+    chdir $args{local_dir} or return if exists $args{local_dir};
+
+    if (eval { require LWP::Simple; 1 }) {
+        LWP::Simple::mirror($args{url}, $file);
+    }
+    elsif (eval { require Net::FTP; 1 }) { eval {
+        # use Net::FTP to get past firewall
+        my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
+        $ftp->login("anonymous", 'anonymous@example.com');
+        $ftp->cwd($path);
+        $ftp->binary;
+        $ftp->get($file) or (warn("$!\n"), return);
+        $ftp->quit;
+    } }
+    elsif (my $ftp = $self->can_run('ftp')) { eval {
+        # no Net::FTP, fallback to ftp.exe
+        require FileHandle;
+        my $fh = FileHandle->new;
+
+        local $SIG{CHLD} = 'IGNORE';
+        unless ($fh->open("|$ftp -n")) {
+            warn "Couldn't open ftp: $!\n";
+            chdir $dir; return;
+        }
+
+        my @dialog = split(/\n/, <<"END_FTP");
+open $host
+user anonymous anonymous\@example.com
+cd $path
+binary
+get $file $file
+quit
+END_FTP
+        foreach (@dialog) { $fh->print("$_\n") }
+        $fh->close;
+    } }
+    else {
+        warn "No working 'ftp' program available!\n";
+        chdir $dir; return;
+    }
+
+    unless (-f $file) {
+        warn "Fetching failed: $@\n";
+        chdir $dir; return;
+    }
+
+    return if exists $args{size} and -s $file != $args{size};
+    system($args{run}) if exists $args{run};
+    unlink($file) if $args{remove};
+
+    print(((!exists $args{check_for} or -e $args{check_for})
+        ? "done!" : "failed! ($!)"), "\n");
+    chdir $dir; return !$?;
+}
+
+1;
diff --git a/src/perl/inc/Module/Install/Makefile.pm b/src/perl/inc/Module/Install/Makefile.pm
new file mode 100644 (file)
index 0000000..05af6ef
--- /dev/null
@@ -0,0 +1,251 @@
+#line 1
+package Module::Install::Makefile;
+
+use strict 'vars';
+use Module::Install::Base;
+use ExtUtils::MakeMaker ();
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+       $VERSION = '0.76';
+       $ISCORE  = 1;
+       @ISA     = qw{Module::Install::Base};
+}
+
+sub Makefile { $_[0] }
+
+my %seen = ();
+
+sub prompt {
+       shift;
+
+       # Infinite loop protection
+       my @c = caller();
+       if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
+               die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
+       }
+
+       # In automated testing, always use defaults
+       if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
+               local $ENV{PERL_MM_USE_DEFAULT} = 1;
+               goto &ExtUtils::MakeMaker::prompt;
+       } else {
+               goto &ExtUtils::MakeMaker::prompt;
+       }
+}
+
+sub makemaker_args {
+       my $self = shift;
+       my $args = ( $self->{makemaker_args} ||= {} );
+       %$args = ( %$args, @_ );
+       return $args;
+}
+
+# For mm args that take multiple space-seperated args,
+# append an argument to the current list.
+sub makemaker_append {
+       my $self = sShift;
+       my $name = shift;
+       my $args = $self->makemaker_args;
+       $args->{name} = defined $args->{$name}
+               ? join( ' ', $args->{name}, @_ )
+               : join( ' ', @_ );
+}
+
+sub build_subdirs {
+       my $self    = shift;
+       my $subdirs = $self->makemaker_args->{DIR} ||= [];
+       for my $subdir (@_) {
+               push @$subdirs, $subdir;
+       }
+}
+
+sub clean_files {
+       my $self  = shift;
+       my $clean = $self->makemaker_args->{clean} ||= {};
+         %$clean = (
+               %$clean, 
+               FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_),
+       );
+}
+
+sub realclean_files {
+       my $self      = shift;
+       my $realclean = $self->makemaker_args->{realclean} ||= {};
+         %$realclean = (
+               %$realclean, 
+               FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_),
+       );
+}
+
+sub libs {
+       my $self = shift;
+       my $libs = ref $_[0] ? shift : [ shift ];
+       $self->makemaker_args( LIBS => $libs );
+}
+
+sub inc {
+       my $self = shift;
+       $self->makemaker_args( INC => shift );
+}
+
+my %test_dir = ();
+
+sub _wanted_t {
+       /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
+}
+
+sub tests_recursive {
+       my $self = shift;
+       if ( $self->tests ) {
+               die "tests_recursive will not work if tests are already defined";
+       }
+       my $dir = shift || 't';
+       unless ( -d $dir ) {
+               die "tests_recursive dir '$dir' does not exist";
+       }
+       %test_dir = ();
+       require File::Find;
+       File::Find::find( \&_wanted_t, $dir );
+       $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
+}
+
+sub write {
+       my $self = shift;
+       die "&Makefile->write() takes no arguments\n" if @_;
+
+       # Make sure we have a new enough
+       require ExtUtils::MakeMaker;
+
+       # MakeMaker can complain about module versions that include
+       # an underscore, even though its own version may contain one!
+       # Hence the funny regexp to get rid of it.  See RT #35800
+       # for details.
+
+       $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
+
+       # Generate the 
+       my $args = $self->makemaker_args;
+       $args->{DISTNAME} = $self->name;
+       $args->{NAME}     = $self->module_name || $self->name;
+       $args->{VERSION}  = $self->version;
+       $args->{NAME}     =~ s/-/::/g;
+       if ( $self->tests ) {
+               $args->{test} = { TESTS => $self->tests };
+       }
+       if ($] >= 5.005) {
+               $args->{ABSTRACT} = $self->abstract;
+               $args->{AUTHOR}   = $self->author;
+       }
+       if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
+               $args->{NO_META} = 1;
+       }
+       if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
+               $args->{SIGN} = 1;
+       }
+       unless ( $self->is_admin ) {
+               delete $args->{SIGN};
+       }
+
+       # merge both kinds of requires into prereq_pm
+       my $prereq = ($args->{PREREQ_PM} ||= {});
+       %$prereq = ( %$prereq,
+               map { @$_ }
+               map { @$_ }
+               grep $_,
+               ($self->configure_requires, $self->build_requires, $self->requires)
+       );
+
+       # Remove any reference to perl, PREREQ_PM doesn't support it
+       delete $args->{PREREQ_PM}->{perl};
+
+       # merge both kinds of requires into prereq_pm
+       my $subdirs = ($args->{DIR} ||= []);
+       if ($self->bundles) {
+               foreach my $bundle (@{ $self->bundles }) {
+                       my ($file, $dir) = @$bundle;
+                       push @$subdirs, $dir if -d $dir;
+                       delete $prereq->{$file};
+               }
+       }
+
+       if ( my $perl_version = $self->perl_version ) {
+               eval "use $perl_version; 1"
+                       or die "ERROR: perl: Version $] is installed, "
+                       . "but we need version >= $perl_version";
+       }
+
+       $args->{INSTALLDIRS} = $self->installdirs;
+
+       my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
+
+       my $user_preop = delete $args{dist}->{PREOP};
+       if (my $preop = $self->admin->preop($user_preop)) {
+               $args{dist} = $preop;
+       }
+
+       my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
+       $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
+}
+
+sub fix_up_makefile {
+       my $self          = shift;
+       my $makefile_name = shift;
+       my $top_class     = ref($self->_top) || '';
+       my $top_version   = $self->_top->VERSION || '';
+
+       my $preamble = $self->preamble 
+               ? "# Preamble by $top_class $top_version\n"
+                       . $self->preamble
+               : '';
+       my $postamble = "# Postamble by $top_class $top_version\n"
+               . ($self->postamble || '');
+
+       local *MAKEFILE;
+       open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+       my $makefile = do { local $/; <MAKEFILE> };
+       close MAKEFILE or die $!;
+
+       $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
+       $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
+       $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
+       $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
+       $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
+
+       # Module::Install will never be used to build the Core Perl
+       # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
+       # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
+       $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
+       #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
+
+       # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
+       $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g;
+
+       # XXX - This is currently unused; not sure if it breaks other MM-users
+       # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
+
+       open  MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+       print MAKEFILE  "$preamble$makefile$postamble" or die $!;
+       close MAKEFILE  or die $!;
+
+       1;
+}
+
+sub preamble {
+       my ($self, $text) = @_;
+       $self->{preamble} = $text . $self->{preamble} if defined $text;
+       $self->{preamble};
+}
+
+sub postamble {
+       my ($self, $text) = @_;
+       $self->{postamble} ||= $self->admin->postamble;
+       $self->{postamble} .= $text if defined $text;
+       $self->{postamble}
+}
+
+1;
+
+__END__
+
+#line 377
diff --git a/src/perl/inc/Module/Install/Metadata.pm b/src/perl/inc/Module/Install/Metadata.pm
new file mode 100644 (file)
index 0000000..90175f0
--- /dev/null
@@ -0,0 +1,487 @@
+#line 1
+package Module::Install::Metadata;
+
+use strict 'vars';
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+       $VERSION = '0.76';
+       $ISCORE  = 1;
+       @ISA     = qw{Module::Install::Base};
+}
+
+my @scalar_keys = qw{
+       name
+       module_name
+       abstract
+       author
+       version
+       distribution_type
+       tests
+       installdirs
+};
+
+my @tuple_keys = qw{
+       configure_requires
+       build_requires
+       requires
+       recommends
+       bundles
+       resources
+};
+
+my @resource_keys = qw{
+       homepage
+       bugtracker
+       repository
+};
+
+sub Meta              { shift          }
+sub Meta_ScalarKeys   { @scalar_keys   }
+sub Meta_TupleKeys    { @tuple_keys    }
+sub Meta_ResourceKeys { @resource_keys }
+
+foreach my $key ( @scalar_keys ) {
+       *$key = sub {
+               my $self = shift;
+               return $self->{values}{$key} if defined wantarray and !@_;
+               $self->{values}{$key} = shift;
+               return $self;
+       };
+}
+
+foreach my $key ( @resource_keys ) {
+       *$key = sub {
+               my $self = shift;
+               unless ( @_ ) {
+                       return () unless $self->{values}{resources};
+                       return map  { $_->[1] }
+                              grep { $_->[0] eq $key }
+                              @{ $self->{values}{resources} };
+               }
+               return $self->{values}{resources}{$key} unless @_;
+               my $uri = shift or die(
+                       "Did not provide a value to $key()"
+               );
+               $self->resources( $key => $uri );
+               return 1;
+       };
+}
+
+sub requires {
+       my $self = shift;
+       while ( @_ ) {
+               my $module  = shift or last;
+               my $version = shift || 0;
+               push @{ $self->{values}{requires} }, [ $module, $version ];
+       }
+       $self->{values}{requires};
+}
+
+sub build_requires {
+       my $self = shift;
+       while ( @_ ) {
+               my $module  = shift or last;
+               my $version = shift || 0;
+               push @{ $self->{values}{build_requires} }, [ $module, $version ];
+       }
+       $self->{values}{build_requires};
+}
+
+sub configure_requires {
+       my $self = shift;
+       while ( @_ ) {
+               my $module  = shift or last;
+               my $version = shift || 0;
+               push @{ $self->{values}{configure_requires} }, [ $module, $version ];
+       }
+       $self->{values}{configure_requires};
+}
+
+sub recommends {
+       my $self = shift;
+       while ( @_ ) {
+               my $module  = shift or last;
+               my $version = shift || 0;
+               push @{ $self->{values}{recommends} }, [ $module, $version ];
+       }
+       $self->{values}{recommends};
+}
+
+sub bundles {
+       my $self = shift;
+       while ( @_ ) {
+               my $module  = shift or last;
+               my $version = shift || 0;
+               push @{ $self->{values}{bundles} }, [ $module, $version ];
+       }
+       $self->{values}{bundles};
+}
+
+# Resource handling
+my %lc_resource = map { $_ => 1 } qw{
+       homepage
+       license
+       bugtracker
+       repository
+};
+
+sub resources {
+       my $self = shift;
+       while ( @_ ) {
+               my $name  = shift or last;
+               my $value = shift or next;
+               if ( $name eq lc $name and ! $lc_resource{$name} ) {
+                       die("Unsupported reserved lowercase resource '$name'");
+               }
+               $self->{values}{resources} ||= [];
+               push @{ $self->{values}{resources} }, [ $name, $value ];
+       }
+       $self->{values}{resources};
+}
+
+# Aliases for build_requires that will have alternative
+# meanings in some future version of META.yml.
+sub test_requires      { shift->build_requires(@_) }
+sub install_requires   { shift->build_requires(@_) }
+
+# Aliases for installdirs options
+sub install_as_core    { $_[0]->installdirs('perl')   }
+sub install_as_cpan    { $_[0]->installdirs('site')   }
+sub install_as_site    { $_[0]->installdirs('site')   }
+sub install_as_vendor  { $_[0]->installdirs('vendor') }
+
+sub sign {
+       my $self = shift;
+       return $self->{values}{sign} if defined wantarray and ! @_;
+       $self->{values}{sign} = ( @_ ? $_[0] : 1 );
+       return $self;
+}
+
+sub dynamic_config {
+       my $self = shift;
+       unless ( @_ ) {
+               warn "You MUST provide an explicit true/false value to dynamic_config\n";
+               return $self;
+       }
+       $self->{values}{dynamic_config} = $_[0] ? 1 : 0;
+       return 1;
+}
+
+sub perl_version {
+       my $self = shift;
+       return $self->{values}{perl_version} unless @_;
+       my $version = shift or die(
+               "Did not provide a value to perl_version()"
+       );
+       $version =~ s/_.+$//;
+       $version = $version + 0; # Numify
+       unless ( $version >= 5.005 ) {
+               die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
+       }
+       $self->{values}{perl_version} = $version;
+       return 1;
+}
+
+sub license {
+       my $self = shift;
+       return $self->{values}{license} unless @_;
+       my $license = shift or die(
+               'Did not provide a value to license()'
+       );
+       $self->{values}{license} = $license;
+
+       # Automatically fill in license URLs
+       if ( $license eq 'perl' ) {
+               $self->resources( license => 'http://dev.perl.org/licenses/' );
+       }
+
+       return 1;
+}
+
+sub all_from {
+       my ( $self, $file ) = @_;
+
+       unless ( defined($file) ) {
+               my $name = $self->name or die(
+                       "all_from called with no args without setting name() first"
+               );
+               $file = join('/', 'lib', split(/-/, $name)) . '.pm';
+               $file =~ s{.*/}{} unless -e $file;
+               unless ( -e $file ) {
+                       die("all_from cannot find $file from $name");
+               }
+       }
+
+       # Some methods pull from POD instead of code.
+       # If there is a matching .pod, use that instead
+       my $pod = $file;
+       $pod =~ s/\.pm$/.pod/i;
+       $pod = $file unless -e $pod;
+
+       # Pull the different values
+       $self->name_from($file)         unless $self->name;
+       $self->version_from($file)      unless $self->version;
+       $self->perl_version_from($file) unless $self->perl_version;
+       $self->author_from($pod)        unless $self->author;
+       $self->license_from($pod)       unless $self->license;
+       $self->abstract_from($pod)      unless $self->abstract;
+
+       return 1;
+}
+
+sub provides {
+       my $self     = shift;
+       my $provides = ( $self->{values}{provides} ||= {} );
+       %$provides = (%$provides, @_) if @_;
+       return $provides;
+}
+
+sub auto_provides {
+       my $self = shift;
+       return $self unless $self->is_admin;
+       unless (-e 'MANIFEST') {
+               warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
+               return $self;
+       }
+       # Avoid spurious warnings as we are not checking manifest here.
+       local $SIG{__WARN__} = sub {1};
+       require ExtUtils::Manifest;
+       local *ExtUtils::Manifest::manicheck = sub { return };
+
+       require Module::Build;
+       my $build = Module::Build->new(
+               dist_name    => $self->name,
+               dist_version => $self->version,
+               license      => $self->license,
+       );
+       $self->provides( %{ $build->find_dist_packages || {} } );
+}
+
+sub feature {
+       my $self     = shift;
+       my $name     = shift;
+       my $features = ( $self->{values}{features} ||= [] );
+       my $mods;
+
+       if ( @_ == 1 and ref( $_[0] ) ) {
+               # The user used ->feature like ->features by passing in the second
+               # argument as a reference.  Accomodate for that.
+               $mods = $_[0];
+       } else {
+               $mods = \@_;
+       }
+
+       my $count = 0;
+       push @$features, (
+               $name => [
+                       map {
+                               ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
+                       } @$mods
+               ]
+       );
+
+       return @$features;
+}
+
+sub features {
+       my $self = shift;
+       while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
+               $self->feature( $name, @$mods );
+       }
+       return $self->{values}{features}
+               ? @{ $self->{values}{features} }
+               : ();
+}
+
+sub no_index {
+       my $self = shift;
+       my $type = shift;
+       push @{ $self->{values}{no_index}{$type} }, @_ if $type;
+       return $self->{values}{no_index};
+}
+
+sub read {
+       my $self = shift;
+       $self->include_deps( 'YAML::Tiny', 0 );
+
+       require YAML::Tiny;
+       my $data = YAML::Tiny::LoadFile('META.yml');
+
+       # Call methods explicitly in case user has already set some values.
+       while ( my ( $key, $value ) = each %$data ) {
+               next unless $self->can($key);
+               if ( ref $value eq 'HASH' ) {
+                       while ( my ( $module, $version ) = each %$value ) {
+                               $self->can($key)->($self, $module => $version );
+                       }
+               } else {
+                       $self->can($key)->($self, $value);
+               }
+       }
+       return $self;
+}
+
+sub write {
+       my $self = shift;
+       return $self unless $self->is_admin;
+       $self->admin->write_meta;
+       return $self;
+}
+
+sub version_from {
+       require ExtUtils::MM_Unix;
+       my ( $self, $file ) = @_;
+       $self->version( ExtUtils::MM_Unix->parse_version($file) );
+}
+
+sub abstract_from {
+       require ExtUtils::MM_Unix;
+       my ( $self, $file ) = @_;
+       $self->abstract(
+               bless(
+                       { DISTNAME => $self->name },
+                       'ExtUtils::MM_Unix'
+               )->parse_abstract($file)
+        );
+}
+
+# Add both distribution and module name
+sub name_from {
+       my ($self, $file) = @_;
+       if (
+               Module::Install::_read($file) =~ m/
+               ^ \s*
+               package \s*
+               ([\w:]+)
+               \s* ;
+               /ixms
+       ) {
+               my ($name, $module_name) = ($1, $1);
+               $name =~ s{::}{-}g;
+               $self->name($name);
+               unless ( $self->module_name ) {
+                       $self->module_name($module_name);
+               }
+       } else {
+               die("Cannot determine name from $file\n");
+       }
+}
+
+sub perl_version_from {
+       my $self = shift;
+       if (
+               Module::Install::_read($_[0]) =~ m/
+               ^
+               (?:use|require) \s*
+               v?
+               ([\d_\.]+)
+               \s* ;
+               /ixms
+       ) {
+               my $perl_version = $1;
+               $perl_version =~ s{_}{}g;
+               $self->perl_version($perl_version);
+       } else {
+               warn "Cannot determine perl version info from $_[0]\n";
+               return;
+       }
+}
+
+sub author_from {
+       my $self    = shift;
+       my $content = Module::Install::_read($_[0]);
+       if ($content =~ m/
+               =head \d \s+ (?:authors?)\b \s*
+               ([^\n]*)
+               |
+               =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
+               .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
+               ([^\n]*)
+       /ixms) {
+               my $author = $1 || $2;
+               $author =~ s{E<lt>}{<}g;
+               $author =~ s{E<gt>}{>}g;
+               $self->author($author);
+       } else {
+               warn "Cannot determine author info from $_[0]\n";
+       }
+}
+
+sub license_from {
+       my $self = shift;
+       if (
+               Module::Install::_read($_[0]) =~ m/
+               (
+                       =head \d \s+
+                       (?:licen[cs]e|licensing|copyright|legal)\b
+                       .*?
+               )
+               (=head\\d.*|=cut.*|)
+               \z
+       /ixms ) {
+               my $license_text = $1;
+               my @phrases      = (
+                       'under the same (?:terms|license) as perl itself' => 'perl',        1,
+                       'GNU public license'                              => 'gpl',         1,
+                       'GNU lesser public license'                       => 'lgpl',        1,
+                       'BSD license'                                     => 'bsd',         1,
+                       'Artistic license'                                => 'artistic',    1,
+                       'GPL'                                             => 'gpl',         1,
+                       'LGPL'                                            => 'lgpl',        1,
+                       'BSD'                                             => 'bsd',         1,
+                       'Artistic'                                        => 'artistic',    1,
+                       'MIT'                                             => 'mit',         1,
+                       'proprietary'                                     => 'proprietary', 0,
+               );
+               while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
+                       $pattern =~ s{\s+}{\\s+}g;
+                       if ( $license_text =~ /\b$pattern\b/i ) {
+                               if ( $osi and $license_text =~ /All rights reserved/i ) {
+                                       print "WARNING: 'All rights reserved' in copyright may invalidate Open Source license.\n";
+                               }
+                               $self->license($license);
+                               return 1;
+                       }
+               }
+       }
+
+       warn "Cannot determine license info from $_[0]\n";
+       return 'unknown';
+}
+
+sub bugtracker_from {
+       my $self    = shift;
+       my $content = Module::Install::_read($_[0]);
+       my @links   = $content =~ m/L\<(http\:\/\/rt\.cpan\.org\/[^>]+)\>/g;
+       unless ( @links ) {
+               warn "Cannot determine bugtracker info from $_[0]\n";
+               return 0;
+       }
+       if ( @links > 1 ) {
+               warn "Found more than on rt.cpan.org link in $_[0]\n";
+               return 0;
+       }
+
+       # Set the bugtracker
+       bugtracker( $links[0] );
+       return 1;
+}
+
+sub install_script {
+       my $self = shift;
+       my $args = $self->makemaker_args;
+       my $exe  = $args->{EXE_FILES} ||= [];
+        foreach ( @_ ) {
+               if ( -f $_ ) {
+                       push @$exe, $_;
+               } elsif ( -d 'script' and -f "script/$_" ) {
+                       push @$exe, "script/$_";
+               } else {
+                       die("Cannot find script '$_'");
+               }
+       }
+}
+
+1;
diff --git a/src/perl/inc/Module/Install/Win32.pm b/src/perl/inc/Module/Install/Win32.pm
new file mode 100644 (file)
index 0000000..f890074
--- /dev/null
@@ -0,0 +1,64 @@
+#line 1
+package Module::Install::Win32;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+       $VERSION = '0.76';
+       @ISA     = qw{Module::Install::Base};
+       $ISCORE  = 1;
+}
+
+# determine if the user needs nmake, and download it if needed
+sub check_nmake {
+       my $self = shift;
+       $self->load('can_run');
+       $self->load('get_file');
+
+       require Config;
+       return unless (
+               $^O eq 'MSWin32'                     and
+               $Config::Config{make}                and
+               $Config::Config{make} =~ /^nmake\b/i and
+               ! $self->can_run('nmake')
+       );
+
+       print "The required 'nmake' executable not found, fetching it...\n";
+
+       require File::Basename;
+       my $rv = $self->get_file(
+               url       => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe',
+               ftp_url   => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe',
+               local_dir => File::Basename::dirname($^X),
+               size      => 51928,
+               run       => 'Nmake15.exe /o > nul',
+               check_for => 'Nmake.exe',
+               remove    => 1,
+       );
+
+       die <<'END_MESSAGE' unless $rv;
+
+-------------------------------------------------------------------------------
+
+Since you are using Microsoft Windows, you will need the 'nmake' utility
+before installation. It's available at:
+
+  http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe
+      or
+  ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe
+
+Please download the file manually, save it to a directory in %PATH% (e.g.
+C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to
+that directory, and run "Nmake15.exe" from there; that will create the
+'nmake.exe' file needed by this module.
+
+You may then resume the installation process described in README.
+
+-------------------------------------------------------------------------------
+END_MESSAGE
+
+}
+
+1;
diff --git a/src/perl/inc/Module/Install/WriteAll.pm b/src/perl/inc/Module/Install/WriteAll.pm
new file mode 100644 (file)
index 0000000..a50d31e
--- /dev/null
@@ -0,0 +1,40 @@
+#line 1
+package Module::Install::WriteAll;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+       $VERSION = '0.76';
+       @ISA     = qw{Module::Install::Base};
+       $ISCORE  = 1;
+}
+
+sub WriteAll {
+       my $self = shift;
+       my %args = (
+               meta        => 1,
+               sign        => 0,
+               inline      => 0,
+               check_nmake => 1,
+               @_,
+       );
+
+       $self->sign(1)                if $args{sign};
+       $self->Meta->write            if $args{meta};
+       $self->admin->WriteAll(%args) if $self->is_admin;
+
+       $self->check_nmake if $args{check_nmake};
+       unless ( $self->makemaker_args->{PL_FILES} ) {
+               $self->makemaker_args( PL_FILES => {} );
+       }
+
+       if ( $args{inline} ) {
+               $self->Inline->write;
+       } else {
+               $self->Makefile->write;
+       }
+}
+
+1;
diff --git a/src/perl/lib/OpenSRF.pm b/src/perl/lib/OpenSRF.pm
new file mode 100644 (file)
index 0000000..4bb598b
--- /dev/null
@@ -0,0 +1,84 @@
+package OpenSRF;
+
+use strict;
+use vars qw/$AUTOLOAD/;
+
+use Error;
+require UNIVERSAL::require;
+
+# $Revision$
+
+=head1 NAME
+
+OpenSRF - Top level class for OpenSRF perl modules.
+
+=head1 VERSION
+
+Version 0.9.1
+
+=cut
+
+our $VERSION = 0.9.1;
+
+=head1 METHODS
+
+=head2 AUTOLOAD
+
+Traps methods calls for methods that have not been defined so they
+don't propogate up the class hierarchy.
+
+=cut
+
+sub AUTOLOAD {
+       my $self = shift;
+       my $type = ref($self) || $self;
+       my $name = $AUTOLOAD;
+       my $otype = ref $self;
+
+       my ($package, $filename, $line) = caller;
+       my ($package1, $filename1, $line1) = caller(1);
+       my ($package2, $filename2, $line2) = caller(2);
+       my ($package3, $filename3, $line3) = caller(3);
+       my ($package4, $filename4, $line4) = caller(4);
+       my ($package5, $filename5, $line5) = caller(5);
+       $name =~ s/.*://;   # strip fully-qualified portion
+       warn <<"        WARN";
+****
+** ${name}() isn't there.  Please create me somewhere (like in $type)!
+** Error at $package ($filename), line $line
+** Call Stack (5 deep):
+**     $package1 ($filename1), line $line1
+**     $package2 ($filename2), line $line2
+**     $package3 ($filename3), line $line3
+**     $package4 ($filename4), line $line4
+**     $package5 ($filename5), line $line5
+** Object type was $otype
+****
+       WARN
+}
+
+
+
+=head2 alert_abstract
+
+This method is called by abstract methods to ensure that the process
+dies when an undefined abstract method is called.
+
+=cut
+
+sub alert_abstract() {
+       my $c = shift;
+       my $class = ref( $c ) || $c;
+       my ($file, $line, $method) = (caller(1))[1..3];
+       die " * Call to abstract method $method at $file, line $line";
+}
+
+=head2 class
+
+Returns the scalar value of its caller.
+
+=cut
+
+sub class { return scalar(caller); }
+
+1;
diff --git a/src/perl/lib/OpenSRF/AppSession.pm b/src/perl/lib/OpenSRF/AppSession.pm
new file mode 100644 (file)
index 0000000..d6bc91a
--- /dev/null
@@ -0,0 +1,1040 @@
+package OpenSRF::AppSession;
+use OpenSRF::DomainObject::oilsMessage;
+use OpenSRF::DomainObject::oilsMethod;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use OpenSRF::Transport::PeerHandle;
+use OpenSRF::Utils::JSON;
+use OpenSRF::Utils::Logger qw(:level);
+use OpenSRF::Utils::SettingsClient;
+use OpenSRF::Utils::Config;
+use OpenSRF::EX;
+use OpenSRF;
+use Exporter;
+use base qw/Exporter OpenSRF/;
+use Time::HiRes qw( time usleep );
+use warnings;
+use strict;
+
+our @EXPORT_OK = qw/CONNECTING INIT_CONNECTED CONNECTED DISCONNECTED CLIENT SERVER/;
+our %EXPORT_TAGS = ( state => [ qw/CONNECTING INIT_CONNECTED CONNECTED DISCONNECTED/ ],
+                endpoint => [ qw/CLIENT SERVER/ ],
+);
+
+my $logger = "OpenSRF::Utils::Logger";
+my $_last_locale = 'en-US';
+
+our %_CACHE;
+our @_RESEND_QUEUE;
+
+sub CONNECTING { return 3 };
+sub INIT_CONNECTED { return 4 };
+sub CONNECTED { return 1 };
+sub DISCONNECTED { return 2 };
+
+sub CLIENT { return 2 };
+sub SERVER { return 1 };
+
+sub find {
+       return undef unless (defined $_[1]);
+       return $_CACHE{$_[1]} if (exists($_CACHE{$_[1]}));
+}
+
+sub transport_connected {
+       my $self = shift;
+       if( ! exists $self->{peer_handle} || ! $self->{peer_handle} ) {
+               return 0;
+       }
+       return $self->{peer_handle}->tcp_connected();
+}
+
+sub connected {
+       my $self = shift;
+       return $self->state == CONNECTED;
+}
+# ----------------------------------------------------------------------------
+# Clears the transport buffers
+# call this if you are not through with the sesssion, but you want 
+# to have a clean slate.  You shouldn't have to call this if
+# you are correctly 'recv'ing all of the data from a request.
+# however, if you don't want all of the data, this will
+# slough off any excess
+#  * * Note: This will delete data for all sessions using this transport
+# handle.  For example, all client sessions use the same handle.
+# ----------------------------------------------------------------------------
+sub buffer_reset {
+
+       my $self = shift;
+       if( ! exists $self->{peer_handle} || ! $self->{peer_handle} ) { 
+               return 0;
+       }
+       $self->{peer_handle}->buffer_reset();
+}
+
+
+# when any incoming data is received, this method is called.
+sub server_build {
+       my $class = shift;
+       $class = ref($class) || $class;
+
+       my $sess_id = shift;
+       my $remote_id = shift;
+       my $service = shift;
+
+       warn "Missing args to server_build():\n" .
+               "sess_id: $sess_id, remote_id: $remote_id, service: $service\n" 
+               unless ($sess_id and $remote_id and $service);
+
+       return undef unless ($sess_id and $remote_id and $service);
+
+       if ( my $thingy = $class->find($sess_id) ) {
+               $thingy->remote_id( $remote_id );
+               return $thingy;
+       }
+
+       if( $service eq "client" ) {
+               #throw OpenSRF::EX::PANIC ("Attempting to build a client session as a server" .
+               #       " Session ID [$sess_id], remote_id [$remote_id]");
+
+               warn "Attempting to build a client session as ".
+                               "a server Session ID [$sess_id], remote_id [$remote_id]";
+
+               $logger->debug("Attempting to build a client session as ".
+                               "a server Session ID [$sess_id], remote_id [$remote_id]", ERROR );
+
+               return undef;
+       }
+
+       my $config_client = OpenSRF::Utils::SettingsClient->new();
+       my $stateless = $config_client->config_value("apps", $service, "stateless");
+
+       #my $max_requests = $conf->$service->max_requests;
+       my $max_requests        = $config_client->config_value("apps",$service,"max_requests");
+       $logger->debug( "Max Requests for $service is $max_requests", INTERNAL ) if (defined $max_requests);
+
+       $logger->transport( "AppSession creating new session: $sess_id", INTERNAL );
+
+       my $self = bless { recv_queue  => [],
+                          request_queue  => [],
+                          requests  => 0,
+                          session_data  => {},
+                          callbacks  => {},
+                          endpoint    => SERVER,
+                          state       => CONNECTING, 
+                          session_id  => $sess_id,
+                          remote_id    => $remote_id,
+                               peer_handle => OpenSRF::Transport::PeerHandle->retrieve($service),
+                               max_requests => $max_requests,
+                               session_threadTrace => 0,
+                               service => $service,
+                               stateless => $stateless,
+                        } => $class;
+
+       return $_CACHE{$sess_id} = $self;
+}
+
+sub session_data {
+       my $self = shift;
+       my ($name, $datum) = @_;
+
+       $self->{session_data}->{$name} = $datum if (defined $datum);
+       return $self->{session_data}->{$name};
+}
+
+sub service { return shift()->{service}; }
+
+sub continue_request {
+       my $self = shift;
+       $self->{'requests'}++;
+       return 1 if (!$self->{'max_requests'});
+       return $self->{'requests'} <= $self->{'max_requests'} ? 1 : 0;
+}
+
+sub last_sent_payload {
+       my( $self, $payload ) = @_;
+       if( $payload ) {
+               return $self->{'last_sent_payload'} = $payload;
+       }
+       return $self->{'last_sent_payload'};
+}
+
+sub session_locale {
+       my( $self, $type ) = @_;
+       if( $type ) {
+        $_last_locale = $type if ($self->endpoint == SERVER);
+               return $self->{'session_locale'} = $type;
+       }
+       return $self->{'session_locale'};
+}
+
+sub last_sent_type {
+       my( $self, $type ) = @_;
+       if( $type ) {
+               return $self->{'last_sent_type'} = $type;
+       }
+       return $self->{'last_sent_type'};
+}
+
+sub get_app_targets {
+       my $app = shift;
+
+       my $conf = OpenSRF::Utils::Config->current;
+       my $router_name = $conf->bootstrap->router_name || 'router';
+       my $domain = $conf->bootstrap->domain;
+       $logger->error("use of <domains/> is deprecated") if $conf->bootstrap->domains;
+
+       unless($router_name and $domain) {
+               throw OpenSRF::EX::Config 
+                       ("Missing router config information 'router_name' and 'domain'");
+       }
+
+    return ("$router_name\@$domain/$app");
+}
+
+sub stateless {
+       my $self = shift;
+       my $state = shift;
+       $self->{stateless} = $state if (defined $state);
+       return $self->{stateless};
+}
+
+# When we're a client and we want to connect to a remote service
+sub create {
+       my $class = shift;
+       $class = ref($class) || $class;
+
+       my $app = shift;
+        my $api_level = shift;
+       my $quiet = shift;
+       my $locale = shift || $_last_locale;
+
+       $api_level = 1 if (!defined($api_level));
+                               
+       $logger->debug( "AppSession creating new client session for $app", DEBUG );
+
+       my $stateless = 0;
+       my $c = OpenSRF::Utils::SettingsClient->new();
+       # we can get an infinite loop if we're grabbing the settings and we
+       # need the settings to grab the settings...
+       if($app ne "opensrf.settings" || $c->has_config()) { 
+               $stateless = $c->config_value("apps", $app, "stateless");
+       }
+
+       my $sess_id = time . rand( $$ );
+       while ( $class->find($sess_id) ) {
+               $sess_id = time . rand( $$ );
+       }
+
+       
+       my ($r_id) = get_app_targets($app);
+
+       my $peer_handle = OpenSRF::Transport::PeerHandle->retrieve("client"); 
+       if( ! $peer_handle ) {
+               $peer_handle = OpenSRF::Transport::PeerHandle->retrieve("system_client");
+       }
+
+       my $self = bless { app_name    => $app,
+                          request_queue  => [],
+                          endpoint    => CLIENT,
+                          state       => DISCONNECTED,#since we're init'ing
+                          session_id  => $sess_id,
+                          remote_id   => $r_id,
+                          raise_error   => $quiet ? 0 : 1,
+                          session_locale   => $locale,
+                          api_level   => $api_level,
+                          orig_remote_id   => $r_id,
+                               peer_handle => $peer_handle,
+                               session_threadTrace => 0,
+                               stateless               => $stateless,
+                        } => $class;
+
+       $logger->debug( "Created new client session $app : $sess_id" );
+
+       return $_CACHE{$sess_id} = $self;
+}
+
+sub raise_remote_errors {
+       my $self = shift;
+       my $err = shift;
+       $self->{raise_error} = $err if (defined $err);
+       return $self->{raise_error};
+}
+
+sub api_level {
+       return shift()->{api_level};
+}
+
+sub app {
+       return shift()->{app_name};
+}
+
+sub reset {
+       my $self = shift;
+       $self->remote_id($$self{orig_remote_id});
+}
+
+# 'connect' can be used as a constructor if called as a class method,
+# or used to connect a session that has disconnectd if called against
+# an existing session that seems to be disconnected, or was just built
+# using 'create' above.
+
+# connect( $app, username => $user, secret => $passwd );
+#    OR
+# connect( $app, sysname => $user, secret => $shared_secret );
+
+# --- Returns undef if the connect attempt times out.
+# --- Returns the OpenSRF::EX object if one is returned by the server
+# --- Returns self if connected
+sub connect {
+       my $self = shift;
+       my $class = ref($self) || $self;
+
+
+       if ( ref( $self ) and  $self->state && $self->state == CONNECTED  ) {
+               $logger->transport("AppSession already connected", DEBUG );
+       } else {
+               $logger->transport("AppSession not connected, connecting..", DEBUG );
+       }
+       return $self if ( ref( $self ) and  $self->state && $self->state == CONNECTED  );
+
+
+       my $app = shift;
+       my $api_level = shift;
+       $api_level = 1 unless (defined $api_level);
+
+       $self = $class->create($app, @_) if (!ref($self));
+
+       return undef unless ($self);
+
+       $self->{api_level} = $api_level;
+
+       $self->reset;
+       $self->state(CONNECTING);
+       $self->send('CONNECT', "");
+
+
+       # if we want to connect to settings, we may not have 
+       # any data for the settings client to work with...
+       # just using a default for now XXX
+
+       my $time_remaining = 5;
+
+
+#      my $client = OpenSRF::Utils::SettingsClient->new();
+#      my $trans = $client->config_value("client_connection","transport_host");
+#
+#      if(!ref($trans)) {
+#              $time_remaining = $trans->{connect_timeout};
+#      } else {
+#              # XXX for now, just use the first
+#              $time_remaining = $trans->[0]->{connect_timeout};
+#      }
+
+       while ( $self->state != CONNECTED  and $time_remaining > 0 ) {
+               my $starttime = time;
+               $self->queue_wait($time_remaining);
+               my $endtime = time;
+               $time_remaining -= ($endtime - $starttime);
+       }
+
+       return undef unless($self->state == CONNECTED);
+
+       $self->stateless(0);
+
+       return $self;
+}
+
+sub finish {
+       my $self = shift;
+       if( ! $self->session_id ) {
+               return 0;
+       }
+}
+
+sub unregister_callback {
+       my $self = shift;
+       my $type = shift;
+       my $cb = shift;
+       if (exists $self->{callbacks}{$type}) {
+               delete $self->{callbacks}{$type}{$cb};
+               return $cb;
+       }
+       return undef;
+}
+
+sub register_callback {
+       my $self = shift;
+       my $type = shift;
+       my $cb = shift;
+       my $cb_key = "$cb";
+       $self->{callbacks}{$type}{$cb_key} = $cb;
+       return $cb_key;
+}
+
+sub kill_me {
+       my $self = shift;
+       if( ! $self->session_id ) { return 0; }
+
+       # run each 'death' callback;
+       if (exists $self->{callbacks}{death}) {
+               for my $sub (values %{$self->{callbacks}{death}}) {
+                       $sub->($self);
+               }
+       }
+
+       $self->disconnect;
+       $logger->transport( "AppSession killing self: " . $self->session_id(), DEBUG );
+       delete $_CACHE{$self->session_id};
+       delete($$self{$_}) for (keys %$self);
+}
+
+sub disconnect {
+       my $self = shift;
+
+       # run each 'disconnect' callback;
+       if (exists $self->{callbacks}{disconnect}) {
+               for my $sub (values %{$self->{callbacks}{disconnect}}) {
+                       $sub->($self);
+               }
+       }
+
+       if ( !$self->stateless and $self->state != DISCONNECTED ) {
+               $self->send('DISCONNECT', "") if ($self->endpoint == CLIENT);
+               $self->state( DISCONNECTED ); 
+       }
+
+       $self->reset;
+}
+
+sub request {
+       my $self = shift;
+       my $meth = shift;
+       return unless $self;
+
+   # tell the logger to create a new xid - the logger will decide if it's really necessary
+   $logger->mk_osrf_xid;
+
+       my $method;
+       if (!ref $meth) {
+               $method = new OpenSRF::DomainObject::oilsMethod ( method => $meth );
+       } else {
+               $method = $meth;
+       }
+       
+       $method->params( @_ );
+
+       $self->send('REQUEST',$method);
+}
+
+sub full_request {
+       my $self = shift;
+       my $meth = shift;
+
+       my $method;
+       if (!ref $meth) {
+               $method = new OpenSRF::DomainObject::oilsMethod ( method => $meth );
+       } else {
+               $method = $meth;
+       }
+       
+       $method->params( @_ );
+
+       $self->send(CONNECT => '', REQUEST => $method, DISCONNECT => '');
+}
+
+sub send {
+       my $self = shift;
+       my @payload_list = @_; # this is a Domain Object
+
+       return unless ($self and $self->{peer_handle});
+
+       $logger->debug( "In send", INTERNAL );
+       
+       my $tT;
+
+       if( @payload_list % 2 ) { $tT = pop @payload_list; }
+
+       if( ! @payload_list ) {
+               $logger->debug( "payload_list param is incomplete in AppSession::send()", ERROR );
+               return undef; 
+       }
+
+       my @doc = ();
+
+       my $disconnect = 0;
+       my $connecting = 0;
+
+       while( @payload_list ) {
+
+               my ($msg_type, $payload) = ( shift(@payload_list), shift(@payload_list) ); 
+
+               if ($msg_type eq 'DISCONNECT' ) {
+                       $disconnect++;
+                       if( $self->state == DISCONNECTED && !$connecting) {
+                               next;
+                       }
+               }
+
+               if( $msg_type eq "CONNECT" ) { 
+                       $connecting++; 
+               }
+
+               my $msg = OpenSRF::DomainObject::oilsMessage->new();
+               $msg->type($msg_type);
+       
+               no warnings;
+               $msg->threadTrace( $tT || int($self->session_threadTrace) || int($self->last_threadTrace) );
+               use warnings;
+       
+               if ($msg->type eq 'REQUEST') {
+                       if ( !defined($tT) || $self->last_threadTrace != $tT ) {
+                               $msg->update_threadTrace;
+                               $self->session_threadTrace( $msg->threadTrace );
+                               $tT = $self->session_threadTrace;
+                               OpenSRF::AppRequest->new($self, $payload);
+                       }
+               }
+       
+               $msg->api_level($self->api_level);
+               $msg->payload($payload) if $payload;
+
+        my $locale = $self->session_locale;
+               $msg->sender_locale($locale) if ($locale);
+       
+               push @doc, $msg;
+
+       
+               $logger->info( "AppSession sending ".$msg->type." to ".$self->remote_id.
+                       " with threadTrace [".$msg->threadTrace."]");
+
+       }
+       
+       if ($self->endpoint == CLIENT and ! $disconnect) {
+               $self->queue_wait(0);
+
+
+               if($self->stateless && $self->state != CONNECTED) {
+                       $self->reset;
+                       $logger->debug("AppSession is stateless in send", INTERNAL );
+               }
+
+               if( !$self->stateless and $self->state != CONNECTED ) {
+
+                       $logger->debug( "Sending connect before request 1", INTERNAL );
+
+                       unless (($self->state == CONNECTING && $connecting )) {
+                               $logger->debug( "Sending connect before request 2", INTERNAL );
+                               my $v = $self->connect();
+                               if( ! $v ) {
+                                       $logger->debug( "Unable to connect to remote service in AppSession::send()", ERROR );
+                                       return undef;
+                               }
+                               if( ref($v) and $v->can("class") and $v->class->isa( "OpenSRF::EX" ) ) {
+                                       return $v;
+                               }
+                       }
+               }
+
+       } 
+       my $json = OpenSRF::Utils::JSON->perl2JSON(\@doc);
+       $logger->internal("AppSession sending doc: $json");
+
+       $self->{peer_handle}->send( 
+                                       to     => $self->remote_id,
+                                  thread => $self->session_id,
+                                  body   => $json );
+
+       if( $disconnect) {
+               $self->state( DISCONNECTED );
+       }
+
+       my $req = $self->app_request( $tT );
+       $req->{_start} = time;
+       return $req
+}
+
+sub app_request {
+       my $self = shift;
+       my $tT = shift;
+       
+       return undef unless (defined $tT);
+       my ($req) = grep { $_->threadTrace == $tT } @{ $self->{request_queue} };
+
+       return $req;
+}
+
+sub remove_app_request {
+       my $self = shift;
+       my $req = shift;
+       
+       my @list = grep { $_->threadTrace != $req->threadTrace } @{ $self->{request_queue} };
+
+       $self->{request_queue} = \@list;
+}
+
+sub endpoint {
+       return $_[0]->{endpoint};
+}
+
+
+sub session_id {
+       my $self = shift;
+       return $self->{session_id};
+}
+
+sub push_queue {
+       my $self = shift;
+       my $resp = shift;
+       my $req = $self->app_request($resp->[1]);
+       return $req->push_queue( $resp->[0] ) if ($req);
+       push @{ $self->{recv_queue} }, $resp->[0];
+}
+
+sub last_threadTrace {
+       my $self = shift;
+       my $new_last_threadTrace = shift;
+
+       my $old_last_threadTrace = $self->{last_threadTrace};
+       if (defined $new_last_threadTrace) {
+               $self->{last_threadTrace} = $new_last_threadTrace;
+               return $new_last_threadTrace unless ($old_last_threadTrace);
+       }
+
+       return $old_last_threadTrace;
+}
+
+sub session_threadTrace {
+       my $self = shift;
+       my $new_last_threadTrace = shift;
+
+       my $old_last_threadTrace = $self->{session_threadTrace};
+       if (defined $new_last_threadTrace) {
+               $self->{session_threadTrace} = $new_last_threadTrace;
+               return $new_last_threadTrace unless ($old_last_threadTrace);
+       }
+
+       return $old_last_threadTrace;
+}
+
+sub last_message_type {
+       my $self = shift;
+       my $new_last_message_type = shift;
+
+       my $old_last_message_type = $self->{last_message_type};
+       if (defined $new_last_message_type) {
+               $self->{last_message_type} = $new_last_message_type;
+               return $new_last_message_type unless ($old_last_message_type);
+       }
+
+       return $old_last_message_type;
+}
+
+sub last_message_api_level {
+       my $self = shift;
+       my $new_last_message_api_level = shift;
+
+       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_api_level;
+}
+
+sub remote_id {
+       my $self = shift;
+       my $new_remote_id = shift;
+
+       my $old_remote_id = $self->{remote_id};
+       if (defined $new_remote_id) {
+               $self->{remote_id} = $new_remote_id;
+               return $new_remote_id unless ($old_remote_id);
+       }
+
+       return $old_remote_id;
+}
+
+sub client_auth {
+       return undef;
+       my $self = shift;
+       my $new_ua = shift;
+
+       my $old_ua = $self->{client_auth};
+       if (defined $new_ua) {
+               $self->{client_auth} = $new_ua;
+               return $new_ua unless ($old_ua);
+       }
+
+       return $old_ua->cloneNode(1);
+}
+
+sub state {
+       my $self = shift;
+       my $new_state = shift;
+
+       my $old_state = $self->{state};
+       if (defined $new_state) {
+               $self->{state} = $new_state;
+               return $new_state unless ($old_state);
+       }
+
+       return $old_state;
+}
+
+sub DESTROY {
+       my $self = shift;
+       delete $$self{$_} for keys %$self;
+       return undef;
+}
+
+sub recv {
+       my $self = shift;
+       my @proto_args = @_;
+       my %args;
+
+       if ( @proto_args ) {
+               if ( !(@proto_args % 2) ) {
+                       %args = @proto_args;
+               } elsif (@proto_args == 1) {
+                       %args = ( timeout => @proto_args );
+               }
+       }
+
+       #$logger->debug( ref($self). " recv_queue before wait: " . $self->_print_queue(), INTERNAL );
+
+       if( exists( $args{timeout} ) ) {
+               $args{timeout} = int($args{timeout});
+               $self->{recv_timeout} = $args{timeout};
+       }
+
+       #$args{timeout} = 0 if ($self->complete);
+
+       if(defined($args{timeout})) {
+               $logger->debug( ref($self) ."->recv with timeout " . $args{timeout}, INTERNAL );
+       }
+
+       my $avail = @{ $self->{recv_queue} };
+       $self->{remaining_recv_timeout} = $self->{recv_timeout};
+
+       if (!$args{count}) {
+               if (wantarray) {
+                       $args{count} = $avail;
+               } else {
+                       $args{count} = 1;
+               }
+       }
+
+       while ( $self->{remaining_recv_timeout} > 0 and $avail < $args{count} ) {
+                       last if $self->complete;
+                       my $starttime = time;
+                       $self->queue_wait($self->{remaining_recv_timeout});
+                       my $endtime = time;
+                       if ($self->{timeout_reset}) {
+                               $self->{timeout_reset} = 0;
+                       } else {
+                               $self->{remaining_recv_timeout} -= ($endtime - $starttime)
+                       }
+                       $avail = @{ $self->{recv_queue} };
+       }
+
+
+       my @list;
+       while ( my $msg = shift @{ $self->{recv_queue} } ) {
+               push @list, $msg;
+               last if (scalar(@list) >= $args{count});
+       }
+
+       $logger->debug( "Number of matched responses: " . @list, DEBUG );
+       $self->queue_wait(0); # check for statuses
+       
+       return $list[0] if (!wantarray);
+       return @list;
+}
+
+sub push_resend {
+       my $self = shift;
+       push @OpenSRF::AppSession::_RESEND_QUEUE, @_;
+}
+
+sub flush_resend {
+       my $self = shift;
+       $logger->debug( "Resending..." . @_RESEND_QUEUE, INTERNAL );
+       while ( my $req = shift @OpenSRF::AppSession::_RESEND_QUEUE ) {
+               $req->resend unless $req->complete;
+       }
+}
+
+
+sub queue_wait {
+       my $self = shift;
+       if( ! $self->{peer_handle} ) { return 0; }
+       my $timeout = shift || 0;
+       $logger->debug( "Calling queue_wait($timeout)" , INTERNAL );
+       my $o = $self->{peer_handle}->process($timeout);
+       $self->flush_resend;
+       return $o;
+}
+
+sub _print_queue {
+       my( $self ) = @_;
+       my $string = "";
+       foreach my $msg ( @{$self->{recv_queue}} ) {
+               $string = $string . $msg->toString(1) . "\n";
+       }
+       return $string;
+}
+
+sub status {
+       my $self = shift;
+       return unless $self;
+       $self->send( 'STATUS', @_ );
+}
+
+sub reset_request_timeout {
+       my $self = shift;
+       my $tt = shift;
+       my $req = $self->app_request($tt);
+       $req->{remaining_recv_timeout} = $req->{recv_timeout};
+       $req->{timout_reset} = 1;
+}
+
+#-------------------------------------------------------------------------------
+
+package OpenSRF::AppRequest;
+use base qw/OpenSRF::AppSession/;
+use OpenSRF::Utils::Logger qw/:level/;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use Time::HiRes qw/time usleep/;
+
+sub new {
+       my $class = shift;
+       $class = ref($class) || $class;
+
+       my $session = shift;
+       my $threadTrace = $session->session_threadTrace || $session->last_threadTrace;
+       my $payload = shift;
+       
+       my $self = {    session                 => $session,
+                       threadTrace             => $threadTrace,
+                       payload                 => $payload,
+                       complete                => 0,
+                       timeout_reset           => 0,
+                       recv_timeout            => 30,
+                       remaining_recv_timeout  => 30,
+                       recv_queue              => [],
+       };
+
+       bless $self => $class;
+
+       push @{ $self->session->{request_queue} }, $self;
+
+       return $self;
+}
+
+sub recv_timeout {
+       my $self = shift;
+       my $timeout = shift;
+       if (defined $timeout) {
+               $self->{recv_timeout} = $timeout;
+               $self->{remaining_recv_timeout} = $timeout;
+       }
+       return $self->{recv_timeout};
+}
+
+sub queue_size {
+       my $size = @{$_[0]->{recv_queue}};
+       return $size;
+}
+       
+sub send {
+       my $self = shift;
+       return unless ($self and $self->session and !$self->complete);
+       $self->session->send(@_);
+}
+
+sub finish {
+       my $self = shift;
+       return unless $self->session;
+       $self->session->remove_app_request($self);
+       delete($$self{$_}) for (keys %$self);
+}
+
+sub session {
+       return shift()->{session};
+}
+
+sub complete {
+       my $self = shift;
+       my $complete = shift;
+       return $self->{complete} if ($self->{complete});
+       if (defined $complete) {
+               $self->{complete} = $complete;
+               $self->{_duration} = time - $self->{_start} if ($self->{complete});
+       } else {
+               $self->session->queue_wait(0);
+       }
+       return $self->{complete};
+}
+
+sub duration {
+       my $self = shift;
+       $self->wait_complete;
+       return $self->{_duration};
+}
+
+sub wait_complete {
+       my $self = shift;
+       my $timeout = shift || 10;
+       my $time_remaining = $timeout;
+
+       while ( ! $self->complete  and $time_remaining > 0 ) {
+               my $starttime = time;
+               $self->queue_wait($time_remaining);
+               my $endtime = time;
+               $time_remaining -= ($endtime - $starttime);
+       }
+
+       return $self->complete;
+}
+
+sub threadTrace {
+       return shift()->{threadTrace};
+}
+
+sub push_queue {
+       my $self = shift;
+       my $resp = shift;
+       if( !$resp ) { return 0; }
+       if( UNIVERSAL::isa($resp, "Error")) {
+               $self->{failed} = $resp;
+               $self->complete(1);
+               #return; eventually...
+       }
+       push @{ $self->{recv_queue} }, $resp;
+}
+
+sub failed {
+       my $self = shift;
+       return $self->{failed};
+}
+
+sub queue_wait {
+       my $self = shift;
+       return $self->session->queue_wait(@_)
+}
+
+sub payload { return shift()->{payload}; }
+
+sub resend {
+       my $self = shift;
+       return unless ($self and $self->session and !$self->complete);
+       OpenSRF::Utils::Logger->debug( "I'm resending the request for threadTrace ". $self->threadTrace, DEBUG);
+       return $self->session->send('REQUEST', $self->payload, $self->threadTrace );
+}
+
+sub status {
+       my $self = shift;
+       my $msg = shift;
+       return unless ($self and $self->session and !$self->complete);
+       $self->session->send( 'STATUS',$msg, $self->threadTrace );
+}
+
+sub stream_push {
+       my $self = shift;
+       my $msg = shift;
+       $self->respond( $msg );
+}
+
+sub respond {
+       my $self = shift;
+       my $msg = shift;
+       return unless ($self and $self->session and !$self->complete);
+
+       my $response;
+       if (ref($msg) && UNIVERSAL::isa($msg, 'OpenSRF::DomainObject::oilsResult')) {
+               $response = $msg;
+       } else {
+               $response = new OpenSRF::DomainObject::oilsResult;
+               $response->content($msg);
+       }
+
+       $self->session->send('RESULT', $response, $self->threadTrace);
+}
+
+sub respond_complete {
+       my $self = shift;
+       my $msg = shift;
+       return unless ($self and $self->session and !$self->complete);
+
+       my $response;
+       if (ref($msg) && UNIVERSAL::isa($msg, 'OpenSRF::DomainObject::oilsResult')) {
+               $response = $msg;
+       } else {
+               $response = new OpenSRF::DomainObject::oilsResult;
+               $response->content($msg);
+       }
+
+       my $stat = OpenSRF::DomainObject::oilsConnectStatus->new(
+               statusCode => STATUS_COMPLETE(),
+               status => 'Request Complete' );
+
+
+       $self->session->send( 'RESULT' => $response, 'STATUS' => $stat, $self->threadTrace);
+       $self->complete(1);
+}
+
+sub register_death_callback {
+       my $self = shift;
+       my $cb = shift;
+       $self->session->register_callback( death => $cb );
+}
+
+
+# utility method.  checks to see of the request failed.
+# if so, throws an OpenSRF::EX::ERROR. if everything is
+# ok, it returns the content of the request
+sub gather {
+       my $self = shift;
+       my $finish = shift;
+       $self->wait_complete;
+       my $resp = $self->recv( timeout => 60 );
+       if( $self->failed() ) { 
+               throw OpenSRF::EX::ERROR
+                       ($self->failed()->stringify());
+       }
+       if(!$resp) { return undef; }
+       my $content = $resp->content;
+       if($finish) { $self->finish();}
+       return $content;
+}
+
+
+package OpenSRF::AppSubrequest;
+
+sub respond {
+       my $self = shift;
+       my $resp = shift;
+       push @{$$self{resp}}, $resp if (defined $resp);
+}
+sub respond_complete { respond(@_); }
+
+sub new {
+       my $class = shift;
+       $class = ref($class) || $class;
+       return bless({resp => [], @_}, $class);
+}
+
+sub responses { @{$_[0]->{resp}} }
+
+sub session {
+       my $x = shift;
+       my $s = shift;
+       $x->{session} = $s if ($s);
+       return $x->{session};
+}
+
+sub status {}
+
+
+1;
+
diff --git a/src/perl/lib/OpenSRF/Application.pm b/src/perl/lib/OpenSRF/Application.pm
new file mode 100644 (file)
index 0000000..0329a02
--- /dev/null
@@ -0,0 +1,745 @@
+package OpenSRF::Application;
+# vim:noet:ts=4
+use vars qw/$_app $log @_METHODS $thunk $server_class/;
+
+use base qw/OpenSRF/;
+use OpenSRF::AppSession;
+use OpenSRF::DomainObject::oilsMethod;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use OpenSRF::Utils::Logger qw/:level $logger/;
+use Data::Dumper;
+use Time::HiRes qw/time/;
+use OpenSRF::EX qw/:try/;
+use Carp;
+use OpenSRF::Utils::JSON;
+#use OpenSRF::UnixServer;  # to get the server class from UnixServer::App
+
+sub DESTROY{};
+
+use strict;
+use warnings;
+
+$log = 'OpenSRF::Utils::Logger';
+
+our $in_request = 0;
+our @pending_requests;
+
+sub package {
+       my $self = shift;
+       return 1 unless ref($self);
+       return $self->{package};
+}
+
+sub signature {
+       my $self = shift;
+       return 0 unless ref($self);
+       return $self->{signature};
+}
+
+sub strict {
+    my $self = shift; 
+    return 0 unless ref($self);
+    return $self->{strict};
+}
+
+sub argc {
+       my $self = shift;
+       return 0 unless ref($self);
+       return $self->{argc};
+}
+
+sub api_name {
+       my $self = shift;
+       return 1 unless ref($self);
+       return $self->{api_name};
+}
+
+sub api_level {
+       my $self = shift;
+       return 1 unless ref($self);
+       return $self->{api_level};
+}
+
+sub session {
+       my $self = shift;
+       my $session = shift;
+
+       if($session) {
+               $self->{session} = $session;
+       }
+       return $self->{session};
+}
+
+sub server_class {
+       my $class = shift;
+       if($class) {
+               $server_class = $class;
+       }
+       return $server_class;
+}
+
+sub thunk {
+       my $self = shift;
+       my $flag = shift;
+       $thunk = $flag if (defined $flag);
+       return $thunk;
+}
+
+sub application_implementation {
+       my $self = shift;
+       my $app = shift;
+
+       if (defined $app) {
+               $_app = $app;
+               $_app->use;
+               if( $@ ) {
+                       $log->error( "Error loading application_implementation: $app -> $@", ERROR);
+               }
+
+       }
+
+       return $_app;
+}
+
+sub handler {
+       my ($self, $session, $app_msg) = @_;
+
+       if( ! $app_msg ) {
+               return 1;  # error?
+       }
+
+       my $app = $self->application_implementation;
+
+       if ($session->last_message_type eq 'REQUEST') {
+
+        my @p = $app_msg->params;
+               my $method_name = $app_msg->method;
+               my $method_proto = $session->last_message_api_level;
+               $log->info("CALL: $method_name [". (@p ? join(', ',@p) : '') ."]");
+
+               my $coderef = $app->method_lookup( $method_name, $method_proto, 1, 1 );
+
+               unless ($coderef) {
+                       $session->status( OpenSRF::DomainObject::oilsMethodException->new( 
+                                               statusCode => STATUS_NOTFOUND(),
+                                               status => "Method [$method_name] not found for $app"));
+                       return 1;
+               }
+
+               unless ($session->continue_request) {
+                       $session->status(
+                               OpenSRF::DomainObject::oilsConnectStatus->new(
+                                               statusCode => STATUS_REDIRECTED(),
+                                               status => 'Disconnect on max requests' ) );
+                       $session->kill_me;
+                       return 1;
+               }
+
+               if (ref $coderef) {
+                       my @args = $app_msg->params;
+                       my $appreq = OpenSRF::AppRequest->new( $session );
+
+                       $log->debug( "in_request = $in_request : [" . $appreq->threadTrace."]", INTERNAL );
+                       if( $in_request ) {
+                               $log->debug( "Pushing onto pending requests: " . $appreq->threadTrace, DEBUG );
+                               push @pending_requests, [ $appreq, \@args, $coderef ]; 
+                               return 1;
+                       }
+
+
+                       $in_request++;
+
+                       $log->debug( "Executing coderef for {$method_name}", INTERNAL );
+
+                       my $resp;
+                       try {
+                               # un-if(0) this block to enable param checking based on signature and argc
+                               if ($coderef->strict) {
+                                       if (@args < $coderef->argc) {
+                                               die     "Not enough params passed to ".
+                                                       $coderef->api_name." : requires ". $coderef->argc
+                                       }
+                                       if (@args) {
+                                               my $sig = $coderef->signature;
+                                               if ($sig && exists $sig->{params}) {
+                                                       for my $p (0 .. scalar(@{ $sig->{params} }) - 1 ) {
+                                                               my $s = $sig->{params}->[$p];
+                                                               my $a = $args[$p];
+                                                               if ($s->{class} && OpenSRF::Utils::JSON->lookup_hint(ref $a) ne $s->{class}) {
+                                                                       die "Incorrect param class at position $p : should be a '$$s{class}'";
+                                                               } elsif ($s->{type}) {
+                                                                       if (lc($s->{type}) eq 'object' && $a !~ /HASH/o) {
+                                                                               die "Incorrect param type at position $p : should be an 'object'";
+                                                                       } elsif (lc($s->{type}) eq 'array' && $a !~ /ARRAY/o) {
+                                                                               die "Incorrect param type at position $p : should be an 'array'";
+                                                                       } elsif (lc($s->{type}) eq 'number' && (ref($a) || $a !~ /^-?\d+(?:\.\d+)?$/o)) {
+                                                                               die "Incorrect param type at position $p : should be a 'number'";
+                                                                       } elsif (lc($s->{type}) eq 'string' && ref($a)) {
+                                                                               die "Incorrect param type at position $p : should be a 'string'";
+                                                                       }
+                                                               }
+                                                       }
+                                               }
+                                       }
+                               }
+
+                               my $start = time();
+                               $resp = $coderef->run( $appreq, @args); 
+                               my $time = sprintf '%.3f', time() - $start;
+
+                               $log->debug( "Method duration for [$method_name]:  ". $time );
+                               if( defined( $resp ) ) {
+                                       $appreq->respond_complete( $resp );
+                               } else {
+                                       $appreq->status( OpenSRF::DomainObject::oilsConnectStatus->new(
+                                                               statusCode => STATUS_COMPLETE(),
+                                                               status => 'Request Complete' ) );
+                               }
+                       } catch Error with {
+                               my $e = shift;
+                               warn "Caught error from 'run' method: $e\n";
+
+                               if(UNIVERSAL::isa($e,"Error")) {
+                                       $e = $e->stringify();
+                               } 
+                               my $sess_id = $session->session_id;
+                               $session->status(
+                                       OpenSRF::DomainObject::oilsMethodException->new(
+                                                       statusCode      => STATUS_INTERNALSERVERERROR(),
+                                                       status          => " *** Call to [$method_name] failed for session ".
+                                                                          "[$sess_id], thread trace ".
+                                                                          "[".$appreq->threadTrace."]:\n$e\n"
+                                       )
+                               );
+                       };
+
+
+
+                       # ----------------------------------------------
+
+
+                       # XXX may need this later
+                       # $_->[1] = 1 for (@OpenSRF::AppSession::_CLIENT_CACHE);
+
+                       $in_request--;
+
+                       $log->debug( "Pending Requests: " . scalar(@pending_requests), INTERNAL );
+
+                       # cycle through queued requests
+                       while( my $aref = shift @pending_requests ) {
+                               $in_request++;
+                               my $resp;
+                               try {
+                                       # un-if(0) this block to enable param checking based on signature and argc
+                                       if (0) {
+                                               if (@args < $aref->[2]->argc) {
+                                                       die     "Not enough params passed to ".
+                                                               $aref->[2]->api_name." : requires ". $aref->[2]->argc
+                                               }
+                                               if (@args) {
+                                                       my $sig = $aref->[2]->signature;
+                                                       if ($sig && exists $sig->{params}) {
+                                                               for my $p (0 .. scalar(@{ $sig->{params} }) - 1 ) {
+                                                                       my $s = $sig->{params}->[$p];
+                                                                       my $a = $args[$p];
+                                                                       if ($s->{class} && OpenSRF::Utils::JSON->lookup_hint(ref $a) ne $s->{class}) {
+                                                                               die "Incorrect param class at position $p : should be a '$$s{class}'";
+                                                                       } elsif ($s->{type}) {
+                                                                               if (lc($s->{type}) eq 'object' && $a !~ /HASH/o) {
+                                                                                       die "Incorrect param type at position $p : should be an 'object'";
+                                                                               } elsif (lc($s->{type}) eq 'array' && $a !~ /ARRAY/o) {
+                                                                                       die "Incorrect param type at position $p : should be an 'array'";
+                                                                               } elsif (lc($s->{type}) eq 'number' && (ref($a) || $a !~ /^-?\d+(?:\.\d+)?$/o)) {
+                                                                                       die "Incorrect param type at position $p : should be a 'number'";
+                                                                               } elsif (lc($s->{type}) eq 'string' && ref($a)) {
+                                                                                       die "Incorrect param type at position $p : should be a 'string'";
+                                                                               }
+                                                                       }
+                                                               }
+                                                       }
+                                               }
+                                       }
+
+                                       my $start = time;
+                                       my $response = $aref->[2]->run( $aref->[0], @{$aref->[1]} );
+                                       my $time = sprintf '%.3f', time - $start;
+                                       $log->debug( "Method duration for [".$aref->[2]->api_name." -> ".join(', ',@{$aref->[1]}).']:  '.$time, DEBUG );
+
+                                       $appreq = $aref->[0];   
+                                       if( ref( $response ) ) {
+                                               $appreq->respond_complete( $response );
+                                       } else {
+                                               $appreq->status( OpenSRF::DomainObject::oilsConnectStatus->new(
+                                                                       statusCode => STATUS_COMPLETE(),
+                                                                       status => 'Request Complete' ) );
+                                       }
+                                       $log->debug( "Executed: " . $appreq->threadTrace, INTERNAL );
+                               } catch Error with {
+                                       my $e = shift;
+                                       if(UNIVERSAL::isa($e,"Error")) {
+                                               $e = $e->stringify();
+                                       }
+                                       $session->status(
+                                               OpenSRF::DomainObject::oilsMethodException->new(
+                                                               statusCode => STATUS_INTERNALSERVERERROR(),
+                                                               status => "Call to [".$aref->[2]->api_name."] faild:  $e"
+                                               )
+                                       );
+                               };
+                               $in_request--;
+                       }
+
+                       return 1;
+               } 
+
+               $log->info("Received non-REQUEST message in Application handler");
+
+               my $res = OpenSRF::DomainObject::oilsMethodException->new( 
+                               status => "Received non-REQUEST message in Application handler");
+               $session->send('ERROR', $res);
+               $session->kill_me;
+               return 1;
+
+       } else {
+               $session->push_queue([ $app_msg, $session->last_threadTrace ]);
+       }
+
+       $session->last_message_type('');
+       $session->last_message_api_level('');
+
+       return 1;
+}
+
+sub is_registered {
+       my $self = shift;
+       my $api_name = shift;
+       my $api_level = shift || 1;
+       return exists($_METHODS[$api_level]{$api_name});
+}
+
+
+sub normalize_whitespace {
+       my $txt = shift;
+
+       $txt =~ s/^\s+//gso;
+       $txt =~ s/\s+$//gso;
+       $txt =~ s/\s+/ /gso;
+       $txt =~ s/\n//gso;
+       $txt =~ s/\. /\.  /gso;
+
+       return $txt;
+}
+
+sub parse_string_signature {
+       my $string = shift;
+       return [] unless $string;
+       my @chunks = split(/\@/smo, $string);
+
+       my @params;
+       my $ret;
+       my $desc = '';
+       for (@chunks) {
+               if (/^return (.+)$/so) {
+                       $ret = [normalize_whitespace($1)];
+               } elsif (/^param (\w+) \b(.+)$/so) {
+                       push @params, [ $1, normalize_whitespace($2) ];
+               } else {
+                       $desc .= '@' if $desc;
+                       $desc .= $_;
+               }
+       }
+
+       return [normalize_whitespace($desc),\@params, $ret];
+}
+
+sub parse_array_signature {
+       my $array = shift;
+       my ($d,$p,$r) = @$array;
+       return {} unless ($d or $p or $r);
+
+       return {
+               desc    => $d,
+               params  => [
+                       map { 
+                               { name  => $$_[0],
+                                 desc  => $$_[1],
+                                 type  => $$_[2],
+                                 class => $$_[3],
+                               }
+                       } @$p
+               ],
+               'return'=>
+                       { desc  => $$r[0],
+                         type  => $$r[1],
+                         class => $$r[2],
+                       }
+       };
+}
+
+sub register_method {
+       my $self = shift;
+       my $app = ref($self) || $self;
+       my %args = @_;
+
+
+       throw OpenSRF::DomainObject::oilsMethodException unless ($args{method});
+
+       $args{api_level} = 1 unless(defined($args{api_level}));
+       $args{stream} ||= 0;
+       $args{remote} ||= 0;
+       $args{argc} ||= 0;
+       $args{package} ||= $app;                
+       $args{server_class} = server_class();
+       $args{api_name} ||= $args{server_class} . '.' . $args{method};
+
+       # un-if(0) this block to enable signature parsing
+       if (!$args{signature}) {
+               if ($args{notes} && !ref($args{notes})) {
+                       $args{signature} =
+                               parse_array_signature( parse_string_signature( $args{notes} ) );
+               }
+       } elsif( !ref($args{signature}) ) {
+               $args{signature} =
+                       parse_array_signature( parse_string_signature( $args{signature} ) );
+       } elsif( ref($args{signature}) eq 'ARRAY') {
+               $args{signature} =
+                       parse_array_signature( $args{signature} );
+       }
+       
+       unless ($args{object_hint}) {
+               ($args{object_hint} = $args{package}) =~ s/::/_/go;
+       }
+
+       OpenSRF::Utils::JSON->register_class_hint( name => $args{package}, hint => $args{object_hint}, type => "hash" );
+
+       $_METHODS[$args{api_level}]{$args{api_name}} = bless \%args => $app;
+
+       __PACKAGE__->register_method(
+               stream => 0,
+               argc => $args{argc},
+               api_name => $args{api_name}.'.atomic',
+               method => 'make_stream_atomic',
+               notes => "This is a system generated method.  Please see the definition for $args{api_name}",
+       ) if ($args{stream});
+}
+
+sub retrieve_remote_apis {
+       my $method = shift;
+       my $session = OpenSRF::AppSession->create('router');
+       try {
+               $session->connect or OpenSRF::EX::WARN->throw("Connection to router timed out");
+       } catch Error with {
+               my $e = shift;
+               $log->debug( "Remote subrequest returned an error:\n". $e );
+               return undef;
+       } finally {
+               return undef unless ($session->state == $session->CONNECTED);
+       };
+
+       my $req = $session->request( 'opensrf.router.info.class.list' );
+       my $list = $req->recv;
+
+       if( UNIVERSAL::isa($list,"Error") ) {
+               throw $list;
+       }
+
+       my $content = $list->content;
+
+       $req->finish;
+       $session->finish;
+       $session->disconnect;
+
+       my %u_list = map { ($_ => 1) } @$content;
+
+       for my $class ( keys %u_list ) {
+               next if($class eq $server_class);
+               populate_remote_method_cache($class, $method);
+       }
+}
+
+sub populate_remote_method_cache {
+       my $class = shift;
+       my $meth = shift;
+
+       my $session = OpenSRF::AppSession->create($class);
+       try {
+               $session->connect or OpenSRF::EX::WARN->throw("Connection to $class timed out");
+
+               my $call = 'opensrf.system.method.all' unless (defined $meth);
+               $call = 'opensrf.system.method' if (defined $meth);
+
+               my $req = $session->request( $call, $meth );
+
+               while (my $method = $req->recv) {
+                       next if (UNIVERSAL::isa($method, 'Error'));
+
+                       $method = $method->content;
+                       next if ( exists($_METHODS[$$method{api_level}]) &&
+                               exists($_METHODS[$$method{api_level}]{$$method{api_name}}) );
+                       $method->{remote} = 1;
+                       bless($method, __PACKAGE__ );
+                       $_METHODS[$$method{api_level}]{$$method{api_name}} = $method;
+               }
+
+               $req->finish;
+               $session->finish;
+               $session->disconnect;
+
+       } catch Error with {
+               my $e = shift;
+               $log->debug( "Remote subrequest returned an error:\n". $e );
+               return undef;
+       };
+}
+
+sub method_lookup {             
+       my $self = shift;
+       my $method = shift;
+       my $proto = shift;
+       my $no_recurse = shift || 0;
+       my $no_remote = shift || 0;
+
+       # this instead of " || 1;" above to allow api_level 0
+       $proto = $self->api_level unless (defined $proto);
+
+       my $class = ref($self) || $self;
+
+       $log->debug("Lookup of [$method] by [$class] in api_level [$proto]", DEBUG);
+       $log->debug("Available methods\n\t".join("\n\t", keys %{ $_METHODS[$proto] }), INTERNAL);
+
+       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) {
+               if($no_remote and $meth->{remote}) {
+                       $log->debug("OH CRAP We're not supposed to return remote methods", WARN);
+                       return undef;
+               }
+
+       } elsif (!$no_recurse) {
+               $log->debug("We didn't find [$method], asking everyone else.", DEBUG);
+               retrieve_remote_apis($method);
+               $meth = $self->method_lookup($method,$proto,1);
+       }
+
+       return $meth;
+}
+
+sub run {
+       my $self = shift;
+       my $req = shift;
+
+       my $resp;
+       my @params = @_;
+
+       if ( !UNIVERSAL::isa($req, 'OpenSRF::AppRequest') ) {
+               $log->debug("Creating a SubRequest object", DEBUG);
+               unshift @params, $req;
+               $req = OpenSRF::AppSubrequest->new;
+               $req->session( $self->session ) if ($self->session);
+
+       } else {
+               $log->debug("This is a top level request", DEBUG);
+       }
+
+       if (!$self->{remote}) {
+               my $code = \&{$self->{package} . '::' . $self->{method}};
+               my $err = undef;
+
+               try {
+                       $resp = $code->($self, $req, @params);
+
+               } catch Error with {
+                       $err = shift;
+
+                       if( ref($self) eq 'HASH') {
+                               $log->error("Sub $$self{package}::$$self{method} DIED!!!\n\t$err\n", ERROR);
+                       }
+               };
+
+               if($err) {
+                       if(UNIVERSAL::isa($err,"Error")) { 
+                               throw $err;
+                       } else {
+                               die $err->stringify; 
+                       }
+               }
+
+
+               $log->debug("Coderef for [$$self{package}::$$self{method}] has been run", DEBUG);
+
+               if ( ref($req) and UNIVERSAL::isa($req, 'OpenSRF::AppSubrequest') ) {
+                       $req->respond($resp) if (defined $resp);
+                       $log->debug("SubRequest object is responding with : " . join(" ",$req->responses), DEBUG);
+                       return $req->responses;
+               } else {
+                       $log->debug("A top level Request object is responding $resp", DEBUG) if (defined $resp);
+                       return $resp;
+               }
+       } else {
+               my $session = OpenSRF::AppSession->create($self->{server_class});
+               try {
+                       #$session->connect or OpenSRF::EX::WARN->throw("Connection to [$$self{server_class}] timed out");
+                       my $remote_req = $session->request( $self->{api_name}, @params );
+                       while (my $remote_resp = $remote_req->recv) {
+                               OpenSRF::Utils::Logger->debug("Remote Subrequest Received " . $remote_resp, INTERNAL );
+                               if( UNIVERSAL::isa($remote_resp,"Error") ) {
+                                       throw $remote_resp;
+                               }
+                               $req->respond( $remote_resp->content );
+                       }
+                       $remote_req->finish();
+
+               } catch Error with {
+                       my $e = shift;
+                       $log->debug( "Remote subrequest returned an error:\n". $e );
+                       return undef;
+               };
+
+               if ($session) {
+                       $session->disconnect();
+                       $session->finish();
+               }
+
+               $log->debug( "Remote Subrequest Responses " . join(" ", $req->responses), INTERNAL );
+
+               return $req->responses;
+       }
+       # huh? how'd we get here...
+       return undef;
+}
+
+sub introspect {
+       my $self = shift;
+       my $client = shift;
+       my $method = shift;
+       my $limit = shift;
+       my $offset = shift;
+
+       if ($self->api_name =~ /all$/o) {
+               $offset = $limit;
+               $limit = $method;
+               $method = undef; 
+       }
+
+       my ($seen,$returned) = (0,0);
+       for my $api_level ( reverse(1 .. $#_METHODS) ) {
+               for my $api_name ( sort keys %{$_METHODS[$api_level]} ) {
+                       if (!$offset || $offset <= $seen) {
+                               if (!$_METHODS[$api_level]{$api_name}{remote}) {
+                                       if (defined($method)) {
+                                               if ($api_name =~ $method) {
+                                                       if (!$limit || $returned < $limit) {
+                                                               $client->respond( $_METHODS[$api_level]{$api_name} );
+                                                               $returned++;
+                                                       }
+                                               }
+                                       } else {
+                                               if (!$limit || $returned < $limit) {
+                                                       $client->respond( $_METHODS[$api_level]{$api_name} );
+                                                       $returned++;
+                                               }
+                                       }
+                               }
+                       }
+                       $seen++;
+               }
+       }
+
+       return undef;
+}
+__PACKAGE__->register_method(
+       stream => 1,
+       method => 'introspect',
+       api_name => 'opensrf.system.method.all',
+       argc => 0,
+       signature => {
+               desc => q/This method is used to introspect an entire OpenSRF Application/,
+               return => {
+                       desc => q/A stream of objects describing the methods available via this OpenSRF Application/,
+                       type => 'object'
+               }
+       },
+);
+__PACKAGE__->register_method(
+       stream => 1,
+       method => 'introspect',
+       argc => 1,
+       api_name => 'opensrf.system.method',
+       argc => 1,
+       signature => {
+               desc => q/Use this method to get the definition of a single OpenSRF Method/,
+               params => [
+                       { desc => q/The method to introspect/,
+                         type => 'string' },
+               ],
+               return => { desc => q/An object describing the method requested, or an error if it can't be found/,
+                           type => 'object' }
+       },
+);
+
+sub echo_method {
+       my $self = shift;
+       my $client = shift;
+       my @args = @_;
+
+       $client->respond( $_ ) for (@args);
+       return undef;
+}
+__PACKAGE__->register_method(
+       stream => 1,
+       method => 'echo_method',
+       argc => 1,
+       api_name => 'opensrf.system.echo',
+       signature => {
+               desc => q/A test method that will echo back it's arguments in a streaming response/,
+               params => [
+                       { desc => q/One or more arguments to echo back/ }
+               ],
+               return => { desc => q/A stream of the arguments passed/ }
+       },
+);
+
+sub time_method {
+       my( $self, $conn ) = @_;
+       return CORE::time;
+}
+__PACKAGE__->register_method(
+       method => 'time_method',
+       argc => 0,
+       api_name => 'opensrf.system.time',
+       signature => {
+               desc => q/Returns the current system time as epoch seconds/,
+               return => { desc => q/epoch seconds/ }
+       }
+);
+
+sub make_stream_atomic {
+       my $self = shift;
+       my $req = shift;
+       my @args = @_;
+
+       (my $m_name = $self->api_name) =~ s/\.atomic$//o;
+       my $m = $self->method_lookup($m_name);
+
+       $m->session( $req->session );
+       my @results = $m->run(@args);
+       $m->session('');
+
+       return \@results;
+}
+
+
+1;
+
+
diff --git a/src/perl/lib/OpenSRF/Application/Client.pm b/src/perl/lib/OpenSRF/Application/Client.pm
new file mode 100644 (file)
index 0000000..f5d11a2
--- /dev/null
@@ -0,0 +1,6 @@
+package OpenSRF::App::Client;
+use base 'OpenSRF::Application';
+use OpenSRF::Utils::Logger qw/:level/;
+
+
+1;
diff --git a/src/perl/lib/OpenSRF/Application/Demo/Math.pm b/src/perl/lib/OpenSRF/Application/Demo/Math.pm
new file mode 100644 (file)
index 0000000..7f41456
--- /dev/null
@@ -0,0 +1,83 @@
+package OpenSRF::Application::Demo::Math;
+use base qw/OpenSRF::Application/;
+use OpenSRF::Application;
+use OpenSRF::Utils::Logger qw/:level/;
+use OpenSRF::DomainObject::oilsResponse;
+use OpenSRF::EX qw/:try/;
+use strict;
+use warnings;
+
+
+sub DESTROY{}
+
+our $log = 'OpenSRF::Utils::Logger';
+
+sub send_request {
+       my $self = shift;
+       my $client = shift;
+
+       my $method_name = shift;
+       my @params = @_;
+
+       my $session = OpenSRF::AppSession->create( "opensrf.dbmath" );
+       my $request = $session->request( "dbmath.$method_name", @params );
+       my $response = $request->recv();
+       if(!$response) { return undef; }
+       if($response->isa("Error")) {throw $response ($response->stringify);}
+       $session->finish();
+
+       return $response->content;
+
+}
+__PACKAGE__->register_method( method => 'send_request', api_name => '_send_request' );
+
+__PACKAGE__->register_method( method => 'add_1', api_name => 'add' );
+sub add_1 {
+       my $self = shift;
+       my $client = shift;
+       my @args = @_;
+
+       my $meth = $self->method_lookup('_send_request');
+       my ($result) = $meth->run('add',@args);
+
+       return $result;
+}
+
+__PACKAGE__->register_method( method => 'sub_1', api_name => 'sub' );
+sub sub_1 {
+       my $self = shift;
+       my $client = shift;
+       my @args = @_;
+
+       my $meth = $self->method_lookup('_send_request');
+       my ($result) = $meth->run('sub',@args);
+
+       return $result;
+}
+
+__PACKAGE__->register_method( method => 'mult_1', api_name => 'mult' );
+sub mult_1 {
+       my $self = shift;
+       my $client = shift;
+       my @args = @_;
+
+       my $meth = $self->method_lookup('_send_request');
+       my ($result) = $meth->run('mult',@args);
+
+       return $result;
+}
+
+__PACKAGE__->register_method( method => 'div_1', api_name => 'div' );
+sub div_1 {
+       my $self = shift;
+       my $client = shift;
+       my @args = @_;
+
+       my $meth = $self->method_lookup('_send_request');
+       my ($result) = $meth->run('div',@args);
+
+       return $result;
+}
+
+
+1;
diff --git a/src/perl/lib/OpenSRF/Application/Demo/MathDB.pm b/src/perl/lib/OpenSRF/Application/Demo/MathDB.pm
new file mode 100644 (file)
index 0000000..6cdc78c
--- /dev/null
@@ -0,0 +1,58 @@
+package OpenSRF::Application::Demo::MathDB;
+use OpenSRF::Utils::JSON;
+use base qw/OpenSRF::Application/;
+use OpenSRF::Application;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use OpenSRF::Utils::Logger qw/:level/;
+use strict;
+use warnings;
+
+sub DESTROY{}
+our $log = 'OpenSRF::Utils::Logger';
+sub initialize {}
+
+__PACKAGE__->register_method( method => 'add_1', api_name => 'dbmath.add' );
+sub add_1 {
+       my $self = shift;
+       my $client = shift;
+
+       my $n1 = shift; 
+       my $n2 = shift;
+       my $a = $n1 + $n2;
+       return OpenSRF::Utils::JSON::number->new($a);
+}
+
+__PACKAGE__->register_method( method => 'sub_1', api_name => 'dbmath.sub' );
+sub sub_1 {
+       my $self = shift;
+       my $client = shift;
+
+       my $n1 = shift; 
+       my $n2 = shift;
+       my $a = $n1 - $n2;
+       return OpenSRF::Utils::JSON::number->new($a);
+}
+
+__PACKAGE__->register_method( method => 'mult_1', api_name => 'dbmath.mult' );
+sub mult_1 {
+       my $self = shift;
+       my $client = shift;
+
+       my $n1 = shift; 
+       my $n2 = shift;
+       my $a = $n1 * $n2;
+       return OpenSRF::Utils::JSON::number->new($a);
+}
+
+__PACKAGE__->register_method( method => 'div_1', api_name => 'dbmath.div' );
+sub div_1 {
+       my $self = shift;
+       my $client = shift;
+
+       my $n1 = shift; 
+       my $n2 = shift;
+       my $a = $n1 / $n2;
+       return OpenSRF::Utils::JSON::number->new($a);
+}
+
+1;
diff --git a/src/perl/lib/OpenSRF/Application/Persist.pm b/src/perl/lib/OpenSRF/Application/Persist.pm
new file mode 100644 (file)
index 0000000..b8b291f
--- /dev/null
@@ -0,0 +1,517 @@
+package OpenSRF::Application::Persist;
+use base qw/OpenSRF::Application/;
+use OpenSRF::Application;
+
+use OpenSRF::Utils::SettingsClient;
+use OpenSRF::EX qw/:try/;
+use OpenSRF::Utils qw/:common/;
+use OpenSRF::Utils::Logger;
+use OpenSRF::Utils::JSON;
+use DBI;
+
+use vars qw/$dbh $log $default_expire_time/;
+
+sub initialize {
+       $log = 'OpenSRF::Utils::Logger';
+
+       $sc = OpenSRF::Utils::SettingsClient->new;
+
+       my $dbfile = $sc->config_value( apps => 'opensrf.persist' => app_settings => 'dbfile');
+       unless ($dbfile) {
+               throw OpenSRF::EX::PANIC ("Can't find my dbfile for SQLite!");
+       }
+
+       my $init_dbh = DBI->connect("dbi:SQLite:dbname=$dbfile","","");
+       $init_dbh->{AutoCommit} = 1;
+       $init_dbh->{RaiseError} = 0;
+
+       $init_dbh->do( <<"      SQL" );
+               CREATE TABLE storage (
+                       id      INTEGER PRIMARY KEY,
+                       name_id INTEGER,
+                       value   TEXT
+               );
+       SQL
+
+       $init_dbh->do( <<"      SQL" );
+               CREATE TABLE store_name (
+                       id      INTEGER PRIMARY KEY,
+                       name    TEXT UNIQUE
+               );
+       SQL
+
+       $init_dbh->do( <<"      SQL" );
+               CREATE TABLE store_expire (
+                       id              INTEGER PRIMARY KEY,
+                       atime           INTEGER,
+                       expire_interval INTEGER
+               );
+       SQL
+
+}
+
+sub child_init {
+       my $sc = OpenSRF::Utils::SettingsClient->new;
+
+       $default_expire_time = $sc->config_value( apps => 'opensrf.persist' => app_settings => 'default_expire_time' );
+       $default_expire_time ||= 300;
+
+       my $dbfile = $sc->config_value( apps => 'opensrf.persist' => app_settings => 'dbfile');
+       unless ($dbfile) {
+               throw OpenSRF::EX::PANIC ("Can't find my dbfile for SQLite!");
+       }
+
+       $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile","","");
+       $dbh->{AutoCommit} = 1;
+       $dbh->{RaiseError} = 0;
+
+}
+
+sub create_store {
+       my $self = shift;
+       my $client = shift;
+
+       my $name = shift || '';
+
+       try {
+       
+               my $continue = 0;
+               try {
+                       _get_name_id($name);
+
+               } catch Error with { 
+                       $continue++;
+               };
+
+               throw OpenSRF::EX::WARN ("Duplicate key:  object name [$name] already exists!  " . $dbh->errstr)
+                       unless ($continue);
+
+               my $sth = $dbh->prepare("INSERT INTO store_name (name) VALUES (?);");
+               $sth->execute($name);
+               $sth->finish;
+
+               unless ($name) {
+                       my $last_id = $dbh->last_insert_id(undef, undef, 'store_name', 'id');
+                       $name = 'AUTOGENERATED!!'.$last_id;
+                       $dbh->do("UPDATE store_name SET name = '$name' WHERE id = '$last_id';");
+               }
+
+               _flush_by_name($name);
+               return $name;
+       } catch Error with {
+               return undef;
+       };
+}
+__PACKAGE__->register_method(
+       api_name => 'opensrf.persist.slot.create',
+       method => 'create_store',
+       argc => 1,
+);
+
+
+sub create_expirable_store {
+       my $self = shift;
+       my $client = shift;
+       my $name = shift || do { throw OpenSRF::EX::InvalidArg ("Expirable slots must be given a name!") };
+       my $time = shift || $default_expire_time;
+
+       try {
+               ($name) = $self->method_lookup( 'opensrf.persist.slot.create' )->run( $name );
+               return undef unless $name;
+
+               $self->method_lookup('opensrf.persist.slot.set_expire')->run($name, $time);
+               return $name;
+       } catch Error with {
+               return undef;
+       };
+
+}
+__PACKAGE__->register_method(
+       api_name => 'opensrf.persist.slot.create_expirable',
+       method => 'create_expirable_store',
+       argc => 2,
+);
+
+sub _update_expire_atime {
+       my $id = shift;
+       $dbh->do('UPDATE store_expire SET atime = ? WHERE id = ?', {}, time(), $id);
+}
+
+sub set_expire_interval {
+       my $self = shift;
+       my $client = shift;
+       my $slot = shift;
+       my $new_interval = shift;
+
+       try {
+               my $etime = interval_to_seconds($new_interval);
+               my $sid = _get_name_id($slot);
+
+               $dbh->do('DELETE FROM store_expire where id = ?', {}, $sid);
+               return 0 if ($etime == 0);
+
+               $dbh->do('INSERT INTO store_expire (id, atime, expire_interval) VALUES (?,?,?);',{},$sid,time(),$etime);
+               return $etime;
+       } 
+}
+__PACKAGE__->register_method(
+       api_name => 'opensrf.persist.slot.set_expire',
+       method => 'set_expire_interval',
+       argc => 2,
+);
+
+sub find_slot {
+       my $self = shift;
+       my $client = shift;
+       my $slot = shift;
+
+       my $sid = _get_name_id($slot);
+       return $slot if ($sid);
+       return undef;
+}
+__PACKAGE__->register_method(
+       api_name => 'opensrf.persist.slot.find',
+       method => 'find_slot',
+       argc => 2,
+);
+
+sub get_expire_interval {
+       my $self = shift;
+       my $client = shift;
+       my $slot = shift;
+
+       my $sid = _get_name_id($slot);
+       my ($int) = $dbh->selectrow_array('SELECT expire_interval FROM store_expire WHERE id = ?;',{},$sid);
+       return undef unless ($int);
+
+       my ($future) = $dbh->selectrow_array('SELECT atime + expire_interval FROM store_expire WHERE id = ?;',{},$sid);
+       return $future - time();
+}
+__PACKAGE__->register_method(
+       api_name => 'opensrf.persist.slot.get_expire',
+       method => 'get_expire_interval',
+       argc => 2,
+);
+
+
+sub _sweep_expired_slots {
+       return if (shift());
+
+       my $expired_slots = $dbh->selectcol_arrayref(<<"        SQL", {}, time() );
+               SELECT id FROM store_expire WHERE (atime + expire_interval) <= ?;
+       SQL
+
+       return unless ($expired_slots);
+
+       $dbh->do('DELETE FROM storage WHERE name_id IN ('.join(',', map { '?' } @$expired_slots).');', {}, @$expired_slots);
+       $dbh->do('DELETE FROM store_expire WHERE id IN ('.join(',', map { '?' } @$expired_slots).');', {}, @$expired_slots);
+       for my $id (@$expired_slots) {
+               _flush_by_name(_get_id_name($id), 1);
+       }
+}
+
+sub add_item {
+       my $self = shift;
+       my $client = shift;
+
+       my $name = shift or do {
+               throw OpenSRF::EX::WARN ("No name specified!");
+       };
+
+       my $value = shift || '';
+
+       try {
+               my $name_id = _get_name_id($name);
+       
+               if ($self->api_name =~ /object/) {
+                       $dbh->do('DELETE FROM storage WHERE name_id = ?;', {}, $name_id);
+               }
+
+               $dbh->do('INSERT INTO storage (name_id,value) VALUES (?,?);', {}, $name_id, OpenSRF::Utils::JSON->perl2JSON($value));
+
+               _flush_by_name($name);
+
+               return $name;
+       } catch Error with {
+               return undef;
+       };
+}
+__PACKAGE__->register_method(
+       api_name => 'opensrf.persist.object.set',
+       method => 'add_item',
+       argc => 2,
+);
+__PACKAGE__->register_method(
+       api_name => 'opensrf.persist.queue.push',
+       method => 'add_item',
+       argc => 2,
+);
+__PACKAGE__->register_method(
+       api_name => 'opensrf.persist.stack.push',
+       method => 'add_item',
+       argc => 2,
+);
+
+sub _get_id_name {
+       my $name = shift or do {
+               throw OpenSRF::EX::WARN ("No slot id specified!");
+       };
+
+
+       my $name_id = $dbh->selectcol_arrayref("SELECT name FROM store_name WHERE id = ?;", {}, $name);
+
+       if (!ref($name_id) || !defined($name_id->[0])) {
+               throw OpenSRF::EX::WARN ("Slot id [$name] does not exist!");
+       }
+
+       return $name_id->[0];
+}
+
+sub _get_name_id {
+       my $name = shift or do {
+               throw OpenSRF::EX::WARN ("No slot name specified!");
+       };
+
+
+       my $name_id = $dbh->selectrow_arrayref("SELECT id FROM store_name WHERE name = ?;", {}, $name);
+
+       if (!ref($name_id) || !defined($name_id->[0])) {
+               throw OpenSRF::EX::WARN ("Slot name [$name] does not exist!");
+       }
+
+       return $name_id->[0];
+}
+
+sub destroy_store {
+       my $self = shift;
+       my $client = shift;
+
+       my $name = shift;
+
+       my $problem = 0;
+       try {
+               my $name_id = _get_name_id($name);
+       
+               $dbh->do("DELETE FROM storage WHERE name_id = ?;", {}, $name_id);
+               $dbh->do("DELETE FROM store_name WHERE id = ?;", {}, $name_id);
+               $dbh->do("DELETE FROM store_expire WHERE id = ?;", {}, $name_id);
+
+               _sweep_expired_slots();
+               return $name;
+       } catch Error with {
+               return undef;
+       };
+
+}
+__PACKAGE__->register_method(
+       api_name => 'opensrf.persist.slot.destroy',
+       method => 'destroy_store',
+       argc => 1,
+);
+
+sub _flush_by_name {
+       my $name = shift;
+       my $no_sweep = shift;
+       my $name_id = _get_name_id($name);
+
+       unless ($no_sweep) {
+               _update_expire_atime($name);
+               _sweep_expired_slots();
+       }
+       
+       if ($name =~ /^AUTOGENERATED!!/) {
+               my $count = $dbh->selectcol_arrayref("SELECT COUNT(*) FROM storage WHERE name_id = ?;", {}, $name_id);
+               if (!ref($count) || $$count[0] == 0) {
+                       $dbh->do("DELETE FROM store_name WHERE name = ?;", {}, $name);
+               }
+       }
+}
+       
+sub pop_queue {
+       my $self = shift;
+       my $client = shift;
+
+       my $name = shift or do {
+               throw OpenSRF::EX::WARN ("No queue name specified!");
+       };
+
+       try {
+               my $name_id = _get_name_id($name);
+
+               my $value = $dbh->selectrow_arrayref('SELECT id, value FROM storage WHERE name_id = ? ORDER BY id ASC LIMIT 1;', {}, $name_id);
+               $dbh->do('DELETE FROM storage WHERE id = ?;',{}, $value->[0]) unless ($self->api_name =~ /peek$/);
+
+               _flush_by_name($name);
+
+               return OpenSRF::Utils::JSON->JSON2perl( $value->[1] );
+       } catch Error with {
+               #my $e = shift;
+               #return $e;
+               return undef;
+       };
+}
+__PACKAGE__->register_method(
+       api_name => 'opensrf.persist.queue.peek',
+       method => 'pop_queue',
+       argc => 1,
+);
+__PACKAGE__->register_method(
+       api_name => 'opensrf.persist.queue.pop',
+       method => 'pop_queue',
+       argc => 1,
+);
+
+
+sub peek_slot {
+       my $self = shift;
+       my $client = shift;
+
+       my $name = shift or do {
+               throw OpenSRF::EX::WARN ("No slot name specified!");
+       };
+       my $name_id = _get_name_id($name);
+
+       my $order = 'ASC';
+       $order = 'DESC' if ($self->api_name =~ /stack/o);
+       
+       my $values = $dbh->selectall_arrayref("SELECT value FROM storage WHERE name_id = ? ORDER BY id $order;", {}, $name_id);
+
+       $client->respond( OpenSRF::Utils::JSON->JSON2perl( $_->[0] ) ) for (@$values);
+
+       _flush_by_name($name);
+       return undef;
+}
+__PACKAGE__->register_method(
+       api_name => 'opensrf.persist.queue.peek.all',
+       method => 'peek_slot',
+       argc => 1,
+       stream => 1,
+);
+__PACKAGE__->register_method(
+       api_name => 'opensrf.persist.stack.peek.all',
+       method => 'peek_slot',
+       argc => 1,
+       stream => 1,
+);
+
+
+sub store_size {
+       my $self = shift;
+       my $client = shift;
+
+       my $name = shift or do {
+               throw OpenSRF::EX::WARN ("No queue name specified!");
+       };
+       my $name_id = _get_name_id($name);
+
+       my $value = $dbh->selectcol_arrayref('SELECT SUM(LENGTH(value)) FROM storage WHERE name_id = ?;', {}, $name_id);
+
+       return OpenSRF::Utils::JSON->JSON2perl( $value->[0] );
+}
+__PACKAGE__->register_method(
+       api_name => 'opensrf.persist.queue.size',
+       method => 'shift_stack',
+       argc => 1,
+);
+__PACKAGE__->register_method(
+       api_name => 'opensrf.persist.stack.size',
+       method => 'shift_stack',
+       argc => 1,
+);
+__PACKAGE__->register_method(
+       api_name => 'opensrf.persist.object.size',
+       method => 'shift_stack',
+       argc => 1,
+);
+
+sub store_depth {
+       my $self = shift;
+       my $client = shift;
+
+       my $name = shift or do {
+               throw OpenSRF::EX::WARN ("No queue name specified!");
+       };
+       my $name_id = _get_name_id($name);
+
+       my $value = $dbh->selectcol_arrayref('SELECT COUNT(*) FROM storage WHERE name_id = ?;', {}, $name_id);
+
+       return OpenSRF::Utils::JSON->JSON2perl( $value->[0] );
+}
+__PACKAGE__->register_method(
+       api_name => 'opensrf.persist.queue.length',
+       method => 'shift_stack',
+       argc => 1,
+);
+__PACKAGE__->register_method(
+       api_name => 'opensrf.persist.stack.depth',
+       method => 'shift_stack',
+       argc => 1,
+);
+
+sub shift_stack {
+       my $self = shift;
+       my $client = shift;
+
+       my $name = shift or do {
+               throw OpenSRF::EX::WARN ("No slot name specified!");
+       };
+
+       try {
+               my $name_id = _get_name_id($name);
+
+               my $value = $dbh->selectrow_arrayref('SELECT id, value FROM storage WHERE name_id = ? ORDER BY id DESC LIMIT 1;', {}, $name_id);
+               $dbh->do('DELETE FROM storage WHERE id = ?;',{}, $value->[0]) unless ($self->api_name =~ /peek$/);
+
+               _flush_by_name($name);
+
+               return OpenSRF::Utils::JSON->JSON2perl( $value->[1] );
+       } catch Error with {
+               my $e = shift;
+               return undef;
+       };
+}
+__PACKAGE__->register_method(
+       api_name => 'opensrf.persist.stack.peek',
+       method => 'shift_stack',
+       argc => 1,
+);
+__PACKAGE__->register_method(
+       api_name => 'opensrf.persist.stack.pop',
+       method => 'shift_stack',
+       argc => 1,
+);
+
+sub get_object {
+       my $self = shift;
+       my $client = shift;
+
+       my $name = shift or do {
+               throw OpenSRF::EX::WARN ("No object name specified!");
+       };
+
+       try {
+               my $name_id = _get_name_id($name);
+
+               my $value = $dbh->selectrow_arrayref('SELECT name_id, value FROM storage WHERE name_id = ? ORDER BY id DESC LIMIT 1;', {}, $name_id);
+               $dbh->do('DELETE FROM storage WHERE name_id = ?',{}, $value->[0]) unless ($self->api_name =~ /peek$/);
+
+               _flush_by_name($name);
+
+               return OpenSRF::Utils::JSON->JSON2perl( $value->[1] );
+       } catch Error with {
+               return undef;
+       };
+}
+__PACKAGE__->register_method(
+       api_name => 'opensrf.persist.object.peek',
+       method => 'shift_stack',
+       argc => 1,
+);
+__PACKAGE__->register_method(
+       api_name => 'opensrf.persist.object.get',
+       method => 'shift_stack',
+       argc => 1,
+);
+
+1;
diff --git a/src/perl/lib/OpenSRF/Application/Settings.pm b/src/perl/lib/OpenSRF/Application/Settings.pm
new file mode 100644 (file)
index 0000000..66d9f32
--- /dev/null
@@ -0,0 +1,42 @@
+package OpenSRF::Application::Settings;
+use OpenSRF::Application;
+use OpenSRF::Utils::SettingsParser;
+use OpenSRF::Utils::Logger qw/$logger/;
+use base 'OpenSRF::Application';
+
+sub child_exit {
+    $logger->debug("settings server child exiting...$$");
+}
+
+
+__PACKAGE__->register_method( method => 'get_host_config', api_name => 'opensrf.settings.host_config.get' );
+sub get_host_config {
+       my( $self, $client, $host ) = @_;
+       my $parser = OpenSRF::Utils::SettingsParser->new();
+       return $parser->get_server_config($host);
+}
+
+__PACKAGE__->register_method( method => 'get_default_config', api_name => 'opensrf.settings.default_config.get' );
+sub get_default_config {
+       my( $self, $client ) = @_;
+       my $parser = OpenSRF::Utils::SettingsParser->new();
+       return $parser->get_default_config();
+}
+
+
+
+
+__PACKAGE__->register_method( method => 'xpath_get', api_name => 'opensrf.settings.xpath.get' );
+
+__PACKAGE__->register_method( 
+               method  => 'xpath_get', 
+               api_name => 'opensrf.settings.xpath.get.raw' );
+
+sub xpath_get {
+       my($self, $client, $xpath) = @_;
+       warn "*************** Received XPATH $xpath\n";
+       return  OpenSRF::Utils::SettingsParser->new()->_get_all( $xpath );
+}
+
+
+1;
diff --git a/src/perl/lib/OpenSRF/DomainObject/oilsMessage.pm b/src/perl/lib/OpenSRF/DomainObject/oilsMessage.pm
new file mode 100644 (file)
index 0000000..240089f
--- /dev/null
@@ -0,0 +1,339 @@
+package OpenSRF::DomainObject::oilsMessage;
+use OpenSRF::Utils::JSON;
+use OpenSRF::AppSession;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use OpenSRF::Utils::Logger qw/:level/;
+use warnings; use strict;
+use OpenSRF::EX qw/:try/;
+
+OpenSRF::Utils::JSON->register_class_hint(hint => 'osrfMessage', name => 'OpenSRF::DomainObject::oilsMessage', type => 'hash');
+
+sub toString {
+       my $self = shift;
+       my $pretty = shift;
+       return OpenSRF::Utils::JSON->perl2prettyJSON($self) if ($pretty);
+       return OpenSRF::Utils::JSON->perl2JSON($self);
+}
+
+sub new {
+       my $self = shift;
+       my $class = ref($self) || $self;
+       my %args = @_;
+       return bless \%args => $class;
+}
+
+
+=head1 NAME
+
+OpenSRF::DomainObject::oilsMessage
+
+=head1
+
+use OpenSRF::DomainObject::oilsMessage;
+
+my $msg = OpenSRF::DomainObject::oilsMessage->new( type => 'CONNECT' );
+
+$msg->payload( $domain_object );
+
+=head1 ABSTRACT
+
+OpenSRF::DomainObject::oilsMessage is used internally to wrap data sent
+between client and server.  It provides the structure needed to authenticate
+session data, and also provides the logic needed to unwrap session data and 
+pass this information along to the Application Layer.
+
+=cut
+
+my $log = 'OpenSRF::Utils::Logger';
+
+=head1 METHODS
+
+=head2 OpenSRF::DomainObject::oilsMessage->type( [$new_type] )
+
+=over 4
+
+Used to specify the type of message.  One of
+B<CONNECT, REQUEST, RESULT, STATUS, ERROR, or DISCONNECT>.
+
+=back
+
+=cut
+
+sub type {
+       my $self = shift;
+       my $val = shift;
+       $self->{type} = $val if (defined $val);
+       return $self->{type};
+}
+
+=head2 OpenSRF::DomainObject::oilsMessage->api_level( [$new_api_level] )
+
+=over 4
+
+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.
+
+=back
+
+=cut
+
+sub api_level {
+       my $self = shift;
+       my $val = shift;
+       $self->{api_level} = $val if (defined $val);
+       return $self->{api_level};
+}
+
+=head2 OpenSRF::DomainObject::oilsMessage->sender_locale( [$locale] );
+
+=over 4
+
+Sets or gets the current message locale hint.  Useful for telling the
+server how you see the world.
+
+=back
+
+=cut
+
+sub sender_locale {
+       my $self = shift;
+       my $val = shift;
+       $self->{locale} = $val if (defined $val);
+       return $self->{locale};
+}
+
+=head2 OpenSRF::DomainObject::oilsMessage->threadTrace( [$new_threadTrace] );
+
+=over 4
+
+Sets or gets the current message sequence identifier, or thread trace number,
+for a message.  Useful as a debugging aid, but that's about it.
+
+=back
+
+=cut
+
+sub threadTrace {
+       my $self = shift;
+       my $val = shift;
+       $self->{threadTrace} = $val if (defined $val);
+       return $self->{threadTrace};
+}
+
+=head2 OpenSRF::DomainObject::oilsMessage->update_threadTrace
+
+=over 4
+
+Increments the threadTrace component of a message.  This is automatic when
+using the normal session processing stack.
+
+=back
+
+=cut
+
+sub update_threadTrace {
+       my $self = shift;
+       my $tT = $self->threadTrace;
+
+       $tT ||= 0;
+       $tT++;
+
+       $log->debug("Setting threadTrace to $tT",DEBUG);
+
+       $self->threadTrace($tT);
+
+       return $tT;
+}
+
+=head2 OpenSRF::DomainObject::oilsMessage->payload( [$new_payload] )
+
+=over 4
+
+Sets or gets the payload of a message.  This should be exactly one object
+of (sub)type domainObject or domainObjectCollection.
+
+=back
+
+=cut
+
+sub payload {
+       my $self = shift;
+       my $val = shift;
+       $self->{payload} = $val if (defined $val);
+       return $self->{payload};
+}
+
+=head2 OpenSRF::DomainObject::oilsMessage->handler( $session_id )
+
+=over 4
+
+Used by the message processing stack to set session state information from the current
+message, and then sends control (via the payload) to the Application layer.
+
+=back
+
+=cut
+
+sub handler {
+       my $self = shift;
+       my $session = shift;
+
+       my $mtype = $self->type;
+       my $locale = $self->sender_locale || '';
+       my $api_level = $self->api_level || 1;
+       my $tT = $self->threadTrace;
+
+    $log->debug("Message locale is $locale", DEBUG);
+
+       $session->last_message_type($mtype);
+       $session->last_message_api_level($api_level);
+       $session->last_threadTrace($tT);
+       $session->session_locale($locale);
+
+       $log->debug(" Received api_level => [$api_level], MType => [$mtype], ".
+                       "from [".$session->remote_id."], threadTrace[".$self->threadTrace."]");
+
+       my $val;
+       if ( $session->endpoint == $session->SERVER() ) {
+               $val = $self->do_server( $session, $mtype, $api_level, $tT );
+
+       } elsif ($session->endpoint == $session->CLIENT()) {
+               $val = $self->do_client( $session, $mtype, $api_level, $tT );
+       }
+
+       if( $val ) {
+               return OpenSRF::Application->handler($session, $self->payload);
+       } else {
+               $log->debug("Request was handled internally", DEBUG);
+       }
+
+       return 1;
+
+}
+
+
+
+# handle server side message processing
+
+# !!! Returning 0 means that we don't want to pass ourselves up to the message layer !!!
+sub do_server {
+       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
+       # sessions which send mangled session exceptions to backends for messages 
+       # that they are not aware of any more.
+       if( $mtype eq 'STATUS' ) { return 0; }
+
+       
+       if ($mtype eq 'DISCONNECT') {
+               $session->disconnect;
+               $session->kill_me;
+               return 0;
+       }
+
+       if ($session->state == $session->CONNECTING()) {
+
+               if($mtype ne "CONNECT" and $session->stateless) {
+                       return 1; #pass the message up the stack
+               }
+
+               # the transport layer thinks this is a new connection. is it?
+               unless ($mtype eq 'CONNECT') {
+                       $log->error("Connection seems to be mangled: Got $mtype instead of CONNECT");
+
+                       my $res = OpenSRF::DomainObject::oilsBrokenSession->new(
+                                       status => "Connection seems to be mangled: Got $mtype instead of CONNECT",
+                       );
+
+                       $session->status($res);
+                       $session->kill_me;
+                       return 0;
+
+               }
+               
+               my $res = OpenSRF::DomainObject::oilsConnectStatus->new;
+               $session->status($res);
+               $session->state( $session->CONNECTED );
+
+               return 0;
+       }
+
+
+       return 1;
+
+}
+
+
+# Handle client side message processing. Return 1 when the the message should be pushed
+# up to the application layer.  return 0 otherwise.
+sub do_client {
+
+       my( $self, $session , $mtype, $api_level, $tT) = @_;
+
+
+       if ($mtype eq 'STATUS') {
+
+               if ($self->payload->statusCode == STATUS_OK) {
+                       $session->state($session->CONNECTED);
+                       $log->debug("We connected successfully to ".$session->app);
+                       return 0;
+               }
+
+               if ($self->payload->statusCode == STATUS_TIMEOUT) {
+                       $session->state( $session->DISCONNECTED );
+                       $session->reset;
+                       $session->connect;
+                       $session->push_resend( $session->app_request($self->threadTrace) );
+                       $log->debug("Disconnected because of timeout");
+                       return 0;
+
+               } elsif ($self->payload->statusCode == STATUS_REDIRECTED) {
+                       $session->state( $session->DISCONNECTED );
+                       $session->reset;
+                       $session->connect;
+                       $session->push_resend( $session->app_request($self->threadTrace) );
+                       $log->debug("Disconnected because of redirect", WARN);
+                       return 0;
+
+               } elsif ($self->payload->statusCode == STATUS_EXPFAILED) {
+                       $session->state( $session->DISCONNECTED );
+                       $log->debug("Disconnected because of mangled session", WARN);
+                       $session->reset;
+                       $session->push_resend( $session->app_request($self->threadTrace) );
+                       return 0;
+
+               } elsif ($self->payload->statusCode == STATUS_CONTINUE) {
+                       $session->reset_request_timeout($self->threadTrace);
+                       return 0;
+
+               } elsif ($self->payload->statusCode == STATUS_COMPLETE) {
+                       my $req = $session->app_request($self->threadTrace);
+                       $req->complete(1) if ($req);
+                       return 0;
+               }
+
+               # add more STATUS handling code here (as 'elsif's), for Message layer status stuff
+
+               #$session->state( $session->DISCONNECTED() );
+               #$session->reset;
+
+       } elsif ($session->state == $session->CONNECTING()) {
+               # This should be changed to check the type of response (is it a connectException?, etc.)
+       }
+
+       if( $self->payload and $self->payload->isa( "ERROR" ) ) { 
+               if ($session->raise_remote_errors) {
+                       $self->payload->throw();
+               }
+       }
+
+       $log->debug("oilsMessage passing to Application: " . $self->type." : ".$session->remote_id );
+
+       return 1;
+
+}
+
+1;
diff --git a/src/perl/lib/OpenSRF/DomainObject/oilsMethod.pm b/src/perl/lib/OpenSRF/DomainObject/oilsMethod.pm
new file mode 100644 (file)
index 0000000..f83727b
--- /dev/null
@@ -0,0 +1,99 @@
+package OpenSRF::DomainObject::oilsMethod;
+
+use OpenSRF::Utils::JSON;
+OpenSRF::Utils::JSON->register_class_hint(hint => 'osrfMethod', name => 'OpenSRF::DomainObject::oilsMethod', type => 'hash');
+
+sub toString {
+       my $self = shift;
+       my $pretty = shift;
+       return OpenSRF::Utils::JSON->perl2prettyJSON($self) if ($pretty);
+       return OpenSRF::Utils::JSON->perl2JSON($self);
+}
+
+sub new {
+       my $self = shift;
+       my $class = ref($self) || $self;
+       my %args = @_;
+       return bless \%args => $class;
+}
+
+
+=head1 NAME
+
+OpenSRF::DomainObject::oilsMethod
+
+=head1 SYNOPSIS
+
+use OpenSRF::DomainObject::oilsMethod;
+
+my $method = OpenSRF::DomainObject::oilsMethod->new( method => 'search' );
+
+$method->return_type( 'mods' );
+
+$method->params( 'title:harry potter' );
+
+$client->send( 'REQUEST', $method );
+
+=head1 METHODS
+
+=head2 OpenSRF::DomainObject::oilsMethod->method( [$new_method_name] )
+
+=over 4
+
+Sets or gets the method name that will be called on the server.  As above,
+this can be specified as a build attribute as well as added to a prebuilt
+oilsMethod object.
+
+=back
+
+=cut
+
+sub method {
+       my $self = shift;
+       my $val = shift;
+       $self->{method} = $val if (defined $val);
+       return $self->{method};
+}
+
+=head2 OpenSRF::DomainObject::oilsMethod->return_type( [$new_return_type] )
+
+=over 4
+
+Sets or gets the return type for this method call.  This can also be supplied as
+a build attribute.
+
+This option does not require that the server return the type you request.  It is
+used as a suggestion when more than one return type or format is possible.
+
+=back
+
+=cut
+
+
+sub return_type {
+       my $self = shift;
+       my $val = shift;
+       $self->{return_type} = $val if (defined $val);
+       return $self->{return_type};
+}
+
+=head2 OpenSRF::DomainObject::oilsMethod->params( @new_params )
+
+=over 4
+
+Sets or gets the parameters for this method call.  Just pass in either text
+parameters, or DOM nodes of any type.
+
+=back
+
+=cut
+
+
+sub params {
+       my $self = shift;
+       my @args = @_;
+       $self->{params} = \@args if (@args);
+       return @{ $self->{params} };
+}
+
+1;
diff --git a/src/perl/lib/OpenSRF/DomainObject/oilsResponse.pm b/src/perl/lib/OpenSRF/DomainObject/oilsResponse.pm
new file mode 100644 (file)
index 0000000..aeaee77
--- /dev/null
@@ -0,0 +1,448 @@
+package OpenSRF::DomainObject::oilsResponse;
+use vars qw/@EXPORT_OK %EXPORT_TAGS/;
+use Exporter;
+use OpenSRF::Utils::JSON;
+use base qw/Exporter/;
+use OpenSRF::Utils::Logger qw/:level/;
+
+OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfResponse', name => 'OpenSRF::DomainObject::oilsResponse', type => 'hash' );
+
+BEGIN {
+@EXPORT_OK = qw/STATUS_CONTINUE STATUS_OK STATUS_ACCEPTED
+                                       STATUS_BADREQUEST STATUS_UNAUTHORIZED STATUS_FORBIDDEN
+                                       STATUS_NOTFOUND STATUS_NOTALLOWED STATUS_TIMEOUT
+                                       STATUS_INTERNALSERVERERROR STATUS_NOTIMPLEMENTED
+                                       STATUS_VERSIONNOTSUPPORTED STATUS_REDIRECTED 
+                                       STATUS_EXPFAILED STATUS_COMPLETE/;
+
+%EXPORT_TAGS = (
+       status => [ qw/STATUS_CONTINUE STATUS_OK STATUS_ACCEPTED
+                                       STATUS_BADREQUEST STATUS_UNAUTHORIZED STATUS_FORBIDDEN
+                                       STATUS_NOTFOUND STATUS_NOTALLOWED STATUS_TIMEOUT
+                                       STATUS_INTERNALSERVERERROR STATUS_NOTIMPLEMENTED
+                                       STATUS_VERSIONNOTSUPPORTED STATUS_REDIRECTED 
+                                       STATUS_EXPFAILED STATUS_COMPLETE/ ],
+);
+
+}
+
+=head1 NAME
+
+OpenSRF::DomainObject::oilsResponse
+
+=head1 SYNOPSIS
+
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+
+my $resp = OpenSRF::DomainObject::oilsResponse->new;
+
+$resp->status( 'a status message' );
+
+$resp->statusCode( STATUS_CONTINUE );
+
+$client->respond( $resp );
+
+=head1 ABSTRACT
+
+OpenSRF::DomainObject::oilsResponse implements the base class for all Application
+layer messages send between the client and server.
+
+=cut
+
+sub STATUS_CONTINUE            { return 100 }
+
+sub STATUS_OK                          { return 200 }
+sub STATUS_ACCEPTED            { return 202 }
+sub STATUS_COMPLETE            { return 205 }
+
+sub STATUS_REDIRECTED  { return 307 }
+
+sub STATUS_BADREQUEST  { return 400 }
+sub STATUS_UNAUTHORIZED        { return 401 }
+sub STATUS_FORBIDDEN           { return 403 }
+sub STATUS_NOTFOUND            { return 404 }
+sub STATUS_NOTALLOWED  { return 405 }
+sub STATUS_TIMEOUT             { return 408 }
+sub STATUS_EXPFAILED           { return 417 }
+
+sub STATUS_INTERNALSERVERERROR { return 500 }
+sub STATUS_NOTIMPLEMENTED                      { return 501 }
+sub STATUS_VERSIONNOTSUPPORTED { return 505 }
+
+my $log = 'OpenSRF::Utils::Logger';
+
+sub toString {
+       my $self = shift;
+       my $pretty = shift;
+       return OpenSRF::Utils::JSON->perl2prettyJSON($self) if ($pretty);
+       return OpenSRF::Utils::JSON->perl2JSON($self);
+}
+
+sub new {
+       my $class = shift;
+       $class = ref($class) || $class;
+
+       my $default_status = eval "\$${class}::status";
+       my $default_statusCode = eval "\$${class}::statusCode";
+
+       my %args = (    status => $default_status,
+                       statusCode => $default_statusCode,
+                       @_ );
+       
+       return bless( \%args => $class );
+}
+
+sub status {
+       my $self = shift;
+       my $val = shift;
+       $self->{status} = $val if (defined $val);
+       return $self->{status};
+}
+
+sub statusCode {
+       my $self = shift;
+       my $val = shift;
+       $self->{statusCode} = $val if (defined $val);
+       return $self->{statusCode};
+}
+
+#-------------------------------------------------------------------------------
+
+package OpenSRF::DomainObject::oilsStatus;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use base 'OpenSRF::DomainObject::oilsResponse';
+use vars qw/$status $statusCode/;
+OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfStatus', name => 'OpenSRF::DomainObject::oilsStatus', type => 'hash' );
+
+=head1 NAME
+
+OpenSRF::DomainObject::oilsException
+
+=head1 SYNOPSIS
+
+use OpenSRF::DomainObject::oilsResponse;
+
+...
+
+# something happens.
+
+$client->status( OpenSRF::DomainObject::oilsStatus->new );
+
+=head1 ABSTRACT
+
+The base class for Status messages sent between client and server.  This
+is implemented on top of the C<OpenSRF::DomainObject::oilsResponse> class, and 
+sets the default B<status> to C<Status> and B<statusCode> to C<STATUS_OK>.
+
+=cut
+
+$status = 'Status';
+$statusCode = STATUS_OK;
+
+#-------------------------------------------------------------------------------
+
+package OpenSRF::DomainObject::oilsConnectStatus;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use base 'OpenSRF::DomainObject::oilsStatus';
+use vars qw/$status $statusCode/;
+OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfConnectStatus', name => 'OpenSRF::DomainObject::oilsConnectStatus', type => 'hash' );
+
+=head1 NAME
+
+OpenSRF::DomainObject::oilsConnectStatus
+
+=head1 SYNOPSIS
+
+use OpenSRF::DomainObject::oilsResponse;
+
+...
+
+# something happens.
+
+$client->status( new OpenSRF::DomainObject::oilsConnectStatus );
+
+=head1 ABSTRACT
+
+The class for Stati relating to the connection status of a session.  This
+is implemented on top of the C<OpenSRF::DomainObject::oilsStatus> class, and 
+sets the default B<status> to C<Connection Successful> and B<statusCode> to C<STATUS_OK>.
+
+=head1 SEE ALSO
+
+B<OpenSRF::DomainObject::oilsStatus>
+
+=cut
+
+$status = 'Connection Successful';
+$statusCode = STATUS_OK;
+
+#-------------------------------------------------------------------------------
+
+package OpenSRF::DomainObject::oilsContinueStatus;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use base 'OpenSRF::DomainObject::oilsStatus';
+use vars qw/$status $statusCode/;
+OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfContinueStatus', name => 'OpenSRF::DomainObject::oilsContinueStatus', type => 'hash' );
+
+=head1 NAME
+
+OpenSRF::DomainObject::oilsContinueStatus
+
+=head1 SYNOPSIS
+
+use OpenSRF::DomainObject::oilsResponse;
+
+...
+
+# something happens.
+
+$client->status( new OpenSRF::DomainObject::oilsContinueStatus );
+
+=head1 ABSTRACT
+
+Implements the STATUS_CONTINUE message, informing the client that it should
+continue to wait for a response to its request.
+
+=head1 SEE ALSO
+
+B<OpenSRF::DomainObject::oilsStatus>
+
+=cut
+
+$status = 'Please hold.  Creating response...';
+$statusCode = STATUS_CONTINUE;
+
+1;
+
+#-------------------------------------------------------------------------------
+
+package OpenSRF::DomainObject::oilsResult;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use base 'OpenSRF::DomainObject::oilsResponse';
+use vars qw/$status $statusCode/;
+OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfResult', name => 'OpenSRF::DomainObject::oilsResult', type => 'hash' );
+
+
+$status = 'OK';
+$statusCode = STATUS_OK;
+
+=head1 NAME
+
+OpenSRF::DomainObject::oilsResult
+
+=head1 SYNOPSIS
+
+use OpenSRF::DomainObject::oilsResponse;
+
+ .... do stuff, create $object ...
+
+my $res = OpenSRF::DomainObject::oilsResult->new;
+
+$res->content($object)
+
+$session->respond( $res );
+
+=head1 ABSTRACT
+
+This is the base class for encapuslating RESULT messages send from the server
+to a client.  It is a subclass of B<OpenSRF::DomainObject::oilsResponse>, and
+sets B<status> to C<OK> and B<statusCode> to C<STATUS_OK>.
+
+=head1 METHODS
+
+=head2 OpenSRF::DomainObject::oilsMessage->content( [$new_content] )
+
+=over 4
+
+Sets or gets the content of the response.  This should be exactly one object
+of (sub)type domainObject or domainObjectCollection.
+
+=back
+
+=cut
+
+sub content {
+        my $self = shift;
+       my $val = shift;
+
+       $self->{content} = $val if (defined $val);
+       return $self->{content};
+}
+
+=head1 SEE ALSO
+
+B<OpenSRF::DomainObject::oilsResponse>
+
+=cut
+
+1;
+
+#-------------------------------------------------------------------------------
+
+package OpenSRF::DomainObject::oilsException;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use OpenSRF::EX;
+use base qw/OpenSRF::EX OpenSRF::DomainObject::oilsResponse/;
+use vars qw/$status $statusCode/;
+use Error;
+OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfException', name => 'OpenSRF::DomainObject::oilsException', type => 'hash' );
+
+sub message {
+       my $self = shift;
+       return '<' . $self->statusCode . '>  ' . $self->status;
+}
+
+sub new {
+       my $class = shift;
+       return $class->OpenSRF::DomainObject::oilsResponse::new( @_ );
+}
+
+
+=head1 NAME
+
+OpenSRF::DomainObject::oilsException
+
+=head1 SYNOPSIS
+
+use OpenSRF::DomainObject::oilsResponse;
+
+...
+
+# something breaks.
+
+$client->send( 'ERROR', OpenSRF::DomainObject::oilsException->new( status => "ARRRRRRG!" ) );
+
+=head1 ABSTRACT
+
+The base class for Exception messages sent between client and server.  This
+is implemented on top of the C<OpenSRF::DomainObject::oilsResponse> class, and 
+sets the default B<status> to C<Exception occurred> and B<statusCode> to C<STATUS_BADREQUEST>.
+
+=cut
+
+$status = 'Exception occurred';
+$statusCode = STATUS_INTERNALSERVERERROR;
+
+#-------------------------------------------------------------------------------
+
+package OpenSRF::DomainObject::oilsConnectException;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use OpenSRF::EX;
+use base qw/OpenSRF::DomainObject::oilsException OpenSRF::EX::ERROR/;
+use vars qw/$status $statusCode/;
+OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfConnectException', name => 'OpenSRF::DomainObject::oilsConnectException', type => 'hash' );
+
+=head1 NAME
+
+OpenSRF::DomainObject::oilsConnectException
+
+=head1 SYNOPSIS
+
+use OpenSRF::DomainObject::oilsResponse;
+
+...
+
+# something breaks while connecting.
+
+$client->send( 'ERROR', new OpenSRF::DomainObject::oilsConnectException );
+
+=head1 ABSTRACT
+
+The class for Exceptions that occur durring the B<CONNECT> phase of a session.  This
+is implemented on top of the C<OpenSRF::DomainObject::oilsException> class, and 
+sets the default B<status> to C<Connect Request Failed> and B<statusCode> to C<STATUS_FORBIDDEN>.
+
+=head1 SEE ALSO
+
+B<OpenSRF::DomainObject::oilsException>
+
+=cut
+
+
+$status = 'Connect Request Failed';
+$statusCode = STATUS_FORBIDDEN;
+
+#-------------------------------------------------------------------------------
+
+package OpenSRF::DomainObject::oilsMethodException;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use base 'OpenSRF::DomainObject::oilsException';
+use vars qw/$status $statusCode/;
+OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfMethodException', name => 'OpenSRF::DomainObject::oilsMethodException', type => 'hash' );
+
+=head1 NAME
+
+OpenSRF::DomainObject::oilsMethodException
+
+=head1 SYNOPSIS
+
+use OpenSRF::DomainObject::oilsResponse;
+
+...
+
+# something breaks while looking up or starting
+# a method call.
+
+$client->send( 'ERROR', new OpenSRF::DomainObject::oilsMethodException );
+
+=head1 ABSTRACT
+
+The class for Exceptions that occur during the B<CONNECT> phase of a session.  This
+is implemented on top of the C<OpenSRF::DomainObject::oilsException> class, and 
+sets the default B<status> to C<Connect Request Failed> and B<statusCode> to C<STATUS_NOTFOUND>.
+
+=head1 SEE ALSO
+
+B<OpenSRF::DomainObject::oilsException>
+
+=cut
+
+
+$status = 'A server error occurred during method execution';
+$statusCode = STATUS_INTERNALSERVERERROR;
+
+# -------------------------------------------
+
+package OpenSRF::DomainObject::oilsServerError;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use base 'OpenSRF::DomainObject::oilsException';
+use vars qw/$status $statusCode/;
+OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfServerError', name => 'OpenSRF::DomainObject::oilsServerError', type => 'hash' );
+
+$status = 'Internal Server Error';
+$statusCode = STATUS_INTERNALSERVERERROR;
+
+# -------------------------------------------
+
+package OpenSRF::DomainObject::oilsBrokenSession;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use OpenSRF::EX;
+use base qw/OpenSRF::DomainObject::oilsException OpenSRF::EX::ERROR/;
+use vars qw/$status $statusCode/;
+OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfBrokenSession', name => 'OpenSRF::DomainObject::oilsBrokenSession', type => 'hash' );
+$status = "Request on Disconnected Session";
+$statusCode = STATUS_EXPFAILED;
+
+#-------------------------------------------------------------------------------
+
+package OpenSRF::DomainObject::oilsXMLParseError;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use OpenSRF::EX;
+use base qw/OpenSRF::DomainObject::oilsException OpenSRF::EX::ERROR/;
+use vars qw/$status $statusCode/;
+OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfXMLParseError', name => 'OpenSRF::DomainObject::oilsXMLParseError', type => 'hash' );
+$status = "XML Parse Error";
+$statusCode = STATUS_EXPFAILED;
+
+#-------------------------------------------------------------------------------
+
+package OpenSRF::DomainObject::oilsAuthException;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use OpenSRF::EX;
+use base qw/OpenSRF::DomainObject::oilsException OpenSRF::EX::ERROR/;
+OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfAuthException', name => 'OpenSRF::DomainObject::oilsAuthException', type => 'hash' );
+use vars qw/$status $statusCode/;
+$status = "Authentication Failure";
+$statusCode = STATUS_FORBIDDEN;
+
+1;
diff --git a/src/perl/lib/OpenSRF/EX.pm b/src/perl/lib/OpenSRF/EX.pm
new file mode 100644 (file)
index 0000000..bf86bda
--- /dev/null
@@ -0,0 +1,224 @@
+package OpenSRF::EX;
+use Error qw(:try);
+use base qw( OpenSRF Error );
+use OpenSRF::Utils::Logger;
+
+my $log = "OpenSRF::Utils::Logger";
+$Error::Debug = 1;
+
+sub new {
+       my( $class, $message ) = @_;
+       $class = ref( $class ) || $class;
+       my $self = {};
+       $self->{'msg'} = ${$class . '::ex_msg_header'} .": $message";
+       return bless( $self, $class );
+}      
+
+sub message() { return $_[0]->{'msg'}; }
+
+sub DESTROY{}
+
+
+=head1 OpenSRF::EX
+
+Top level exception.  This class logs an exception when it is thrown.  Exception subclasses
+should subclass one of OpenSRF::EX::INFO, NOTICE, WARN, ERROR, CRITICAL, and PANIC and provide
+a new() method that takes a message and a message() method that returns that message.
+
+=cut
+
+=head2 Synopsis
+
+
+       throw OpenSRF::EX::Jabber ("I Am Dying");
+
+       OpenSRF::EX::InvalidArg->throw( "Another way" );
+
+       my $je = OpenSRF::EX::Jabber->new( "I Cannot Connect" );
+       $je->throw();
+
+
+       See OpenSRF/EX.pm for example subclasses.
+
+=cut
+
+# Log myself and throw myself
+
+#sub message() { shift->alert_abstract(); }
+
+#sub new() { shift->alert_abstract(); }
+
+sub throw() {
+
+       my $self = shift;
+
+       if( ! ref( $self ) || scalar( @_ ) ) {
+               $self = $self->new( @_ );
+       }
+
+       if(             $self->class->isa( "OpenSRF::EX::INFO" )        ||
+                               $self->class->isa( "OpenSRF::EX::NOTICE" ) ||
+                               $self->class->isa( "OpenSRF::EX::WARN" ) ) {
+
+               $log->debug( $self->stringify(), $log->DEBUG );
+       }
+
+       else{ $log->debug( $self->stringify(), $log->ERROR ); }
+       
+       $self->SUPER::throw;
+}
+
+
+sub stringify() {
+       my $self = shift;
+       my($package, $file, $line) = get_caller();
+       my $name = ref($self);
+       my $msg = $self->message();
+
+    my ($sec,$min,$hour,$mday,$mon,$year) = localtime();
+    $year += 1900; $mon += 1;
+    my $date = sprintf(
+        '%s-%0.2d-%0.2dT%0.2d:%0.2d:%0.2d',
+        $year, $mon, $mday, $hour, $min, $sec);
+
+    return "Exception: $name $date $package $file:$line $msg\n";
+}
+
+
+# --- determine the originating caller of this exception
+sub get_caller() {
+
+       my $package = caller();
+       my $x = 0;
+       while( $package->isa( "Error" ) || $package =~ /^Error::/ ) { 
+               $package = caller( ++$x );
+       }
+       return (caller($x));
+}
+
+
+
+
+# -------------------------------------------------------------------
+# -------------------------------------------------------------------
+
+# Top level exception subclasses defining the different exception
+# levels.
+
+# -------------------------------------------------------------------
+
+package OpenSRF::EX::INFO;
+use base qw(OpenSRF::EX);
+our $ex_msg_header = "System INFO";
+
+# -------------------------------------------------------------------
+
+package OpenSRF::EX::NOTICE;
+use base qw(OpenSRF::EX);
+our $ex_msg_header = "System NOTICE";
+
+# -------------------------------------------------------------------
+
+package OpenSRF::EX::WARN;
+use base qw(OpenSRF::EX);
+our $ex_msg_header = "System WARNING";
+
+# -------------------------------------------------------------------
+
+package OpenSRF::EX::ERROR;
+use base qw(OpenSRF::EX);
+our $ex_msg_header = "System ERROR";
+
+# -------------------------------------------------------------------
+
+package OpenSRF::EX::CRITICAL;
+use base qw(OpenSRF::EX);
+our $ex_msg_header = "System CRITICAL";
+
+# -------------------------------------------------------------------
+
+package OpenSRF::EX::PANIC;
+use base qw(OpenSRF::EX);
+our $ex_msg_header = "System PANIC";
+
+# -------------------------------------------------------------------
+# -------------------------------------------------------------------
+
+# Some basic exceptions
+
+# -------------------------------------------------------------------
+package OpenSRF::EX::Jabber;
+use base 'OpenSRF::EX::ERROR';
+our $ex_msg_header = "Jabber Exception";
+
+package OpenSRF::EX::JabberDisconnected;
+use base 'OpenSRF::EX::ERROR';
+our $ex_msg_header = "JabberDisconnected Exception";
+
+=head2 OpenSRF::EX::Jabber
+
+Thrown when there is a problem using the Jabber service
+
+=cut
+
+package OpenSRF::EX::Transport;
+use base 'OpenSRF::EX::ERROR';
+our $ex_msg_header = "Transport Exception";
+
+
+
+# -------------------------------------------------------------------
+package OpenSRF::EX::InvalidArg;
+use base 'OpenSRF::EX::ERROR';
+our $ex_msg_header = "Invalid Arg Exception";
+
+=head2 OpenSRF::EX::InvalidArg
+
+Thrown where an argument to a method was invalid or not provided
+
+=cut
+
+
+# -------------------------------------------------------------------
+package OpenSRF::EX::Socket;
+use base 'OpenSRF::EX::ERROR';
+our $ex_msg_header = "Socket Exception";
+
+=head2 OpenSRF::EX::Socket
+
+Thrown when there is a network layer exception
+
+=cut
+
+
+
+# -------------------------------------------------------------------
+package OpenSRF::EX::Config;
+use base 'OpenSRF::EX::PANIC';
+our $ex_msg_header = "Config Exception";
+
+=head2 OpenSRF::EX::Config
+
+Thrown when a package requires a config option that it cannot retrieve
+or the config file itself cannot be loaded
+
+=cut
+
+
+# -------------------------------------------------------------------
+package OpenSRF::EX::User;
+use base 'OpenSRF::EX::ERROR';
+our $ex_msg_header = "User Exception";
+
+=head2 OpenSRF::EX::User
+
+Thrown when an error occurs due to user identification information
+
+=cut
+
+package OpenSRF::EX::Session;
+use base 'OpenSRF::EX::ERROR';
+our $ex_msg_header = "Session Error";
+
+
+1;
diff --git a/src/perl/lib/OpenSRF/MultiSession.pm b/src/perl/lib/OpenSRF/MultiSession.pm
new file mode 100644 (file)
index 0000000..dd0579c
--- /dev/null
@@ -0,0 +1,283 @@
+package OpenSRF::MultiSession;
+use OpenSRF::AppSession;
+use OpenSRF::Utils::Logger;
+use Time::HiRes qw/time usleep/;
+
+my $log = 'OpenSRF::Utils::Logger';
+
+sub new {
+       my $class = shift;
+       $class = ref($class) || $class;
+
+       my $self = bless {@_} => $class;
+
+       $self->{api_level} = 1 if (!defined($self->{api_level}));
+       $self->{session_hash_function} = \&_dummy_session_hash_function
+               if (!defined($self->{session_hash_function}));
+
+       if ($self->{cap}) {
+               $self->session_cap($self->{cap}) if (!$self->session_cap);
+               $self->request_cap($self->{cap}) if (!$self->request_cap);
+       }
+
+       if (!$self->session_cap) {
+               # XXX make adaptive the default once the logic is in place
+               #$self->adaptive(1);
+
+               $self->session_cap(10);
+       }
+       if (!$self->request_cap) {
+               # XXX make adaptive the default once the logic is in place
+               #$self->adaptive(1);
+
+               $self->request_cap(10);
+       }
+
+       $self->{sessions} = [];
+       $self->{running} = [];
+       $self->{completed} = [];
+       $self->{failed} = [];
+
+       for ( 1 .. $self->session_cap) {
+               push @{ $self->{sessions} },
+                       OpenSRF::AppSession->create(
+                               $self->{app},
+                               $self->{api_level},
+                               1
+                       );
+               #print "Creating connection ".$self->{sessions}->[-1]->session_id." ...\n";
+               $log->debug("Creating connection ".$self->{sessions}->[-1]->session_id." ...");
+       }
+
+       return $self;
+}
+
+sub _dummy_session_hash_function {
+       my $self = shift;
+       $self->{_dummy_hash_counter} = 1 if (!exists($self->{_dummy_hash_counter}));
+       return $self->{_dummy_hash_counter}++;
+}
+
+sub connect {
+       my $self = shift;
+       for my $ses (@{$self->{sessions}}) {
+               $ses->connect unless ($ses->connected);
+       }
+}
+
+sub finish {
+       my $self = shift;
+       $_->finish for (@{$self->{sessions}});
+}
+
+sub disconnect {
+       my $self = shift;
+       $_->disconnect for (@{$self->{sessions}});
+}
+
+sub session_hash_function {
+       my $self = shift;
+       my $session_hash_function = shift;
+       return unless (ref $self);
+
+       $self->{session_hash_function} = $session_hash_function if (defined $session_hash_function);
+       return $self->{session_hash_function};
+}
+
+sub failure_handler {
+       my $self = shift;
+       my $failure_handler = shift;
+       return unless (ref $self);
+
+       $self->{failure_handler} = $failure_handler if (defined $failure_handler);
+       return $self->{failure_handler};
+}
+
+sub success_handler {
+       my $self = shift;
+       my $success_handler = shift;
+       return unless (ref $self);
+
+       $self->{success_handler} = $success_handler if (defined $success_handler);
+       return $self->{success_handler};
+}
+
+sub session_cap {
+       my $self = shift;
+       my $cap = shift;
+       return unless (ref $self);
+
+       $self->{session_cap} = $cap if (defined $cap);
+       return $self->{session_cap};
+}
+
+sub request_cap {
+       my $self = shift;
+       my $cap = shift;
+       return unless (ref $self);
+
+       $self->{request_cap} = $cap if (defined $cap);
+       return $self->{request_cap};
+}
+
+sub adaptive {
+       my $self = shift;
+       my $adapt = shift;
+       return unless (ref $self);
+
+       $self->{adaptive} = $adapt if (defined $adapt);
+       return $self->{adaptive};
+}
+
+sub completed {
+       my $self = shift;
+       my $count = shift;
+       return unless (ref $self);
+
+
+       if (wantarray) {
+               $count ||= scalar @{$self->{completed}}; 
+       }
+
+       if (defined $count) {
+               return () unless (@{$self->{completed}});
+               return splice @{$self->{completed}}, 0, $count;
+       }
+
+       return scalar @{$self->{completed}};
+}
+
+sub failed {
+       my $self = shift;
+       my $count = shift;
+       return unless (ref $self);
+
+
+       if (wantarray) {
+               $count ||= scalar @{$self->{failed}}; 
+       }
+
+       if (defined $count) {
+               return () unless (@{$self->{failed}});
+               return splice @{$self->{failed}}, 0, $count;
+       }
+
+       return scalar @{$self->{failed}};
+}
+
+sub running {
+       my $self = shift;
+       return unless (ref $self);
+       return scalar(@{ $self->{running} });
+}
+
+
+sub request {
+       my $self = shift;
+       my $hash_param;
+
+       my $method = shift;
+       if (ref $method) {
+               $hash_param = $method;
+               $method = shift;
+       }
+
+       my @params = @_;
+
+       $self->session_reap;
+       if ($self->running < $self->request_cap ) {
+               my $index = $self->session_hash_function->($self, (defined $hash_param ? $hash_param : ()), $method, @params);
+               my $ses = $self->{sessions}->[$index % $self->session_cap]; 
+
+               #print "Running $method using session ".$ses->session_id."\n";
+
+               my $req = $ses->request( $method, @params );
+
+               push @{ $self->{running} },
+                       { req => $req,
+                         meth => $method,
+                         hash => $hash_param,
+                         params => [@params]
+                       };
+
+               $log->debug("Making request [$method] ".$self->running."...");
+
+               return $req;
+       } elsif (!$self->adaptive) {
+               #print "Oops.  Too many running: ".$self->running."\n";
+               $self->session_wait;
+               return $self->request((defined $hash_param ? $hash_param : ()), $method => @params);
+       } else {
+               # XXX do addaptive stuff ...
+       }
+}
+
+sub session_wait {
+       my $self = shift;
+       my $all = shift;
+
+       my $count;
+       if ($all) {
+               $count = $self->running;
+               while ($self->running) {
+                       $self->session_reap;
+               }
+               return $count;
+       } else {
+               while(($count = $self->session_reap) == 0 && $self->running) {
+                       usleep 100;
+               }
+               return $count;
+       }
+}
+
+sub session_reap {
+       my $self = shift;
+
+       my @done;
+       my @running;
+       while ( my $req = shift @{ $self->{running} } ) {
+               if ($req->{req}->complete) {
+                       #print "Currently running: ".$self->running."\n";
+
+                       $req->{response} = [ $req->{req}->recv ];
+                       $req->{duration} = $req->{req}->duration;
+
+                       #print "Completed ".$req->{meth}." in session ".$req->{req}->session->session_id." [$req->{duration}]\n";
+
+                       if ($req->{req}->failed) {
+                               #print "ARG!!!! Failed command $req->{meth} in session ".$req->{req}->session->session_id."\n";
+                               $req->{error} = $req->{req}->failed;
+                               push @{ $self->{failed} }, $req;
+                       } else {
+                               push @{ $self->{completed} }, $req;
+                       }
+
+                       push @done, $req;
+
+               } else {
+                       #$log->debug("Still running ".$req->{meth}." in session ".$req->{req}->session->session_id);
+                       push @running, $req;
+               }
+       }
+       push @{ $self->{running} }, @running;
+
+       for my $req ( @done ) {
+               my $handler = $req->{error} ? $self->failure_handler : $self->success_handler;
+               $handler->($self, $req) if ($handler);
+
+               $req->{req}->finish;
+               delete $$req{$_} for (keys %$req);
+
+       }
+
+       my $complete = scalar @done;
+       my $incomplete = scalar @running;
+
+       #$log->debug("Still running $incomplete, completed $complete");
+
+       return $complete;
+}
+
+1;
+
diff --git a/src/perl/lib/OpenSRF/System.pm b/src/perl/lib/OpenSRF/System.pm
new file mode 100644 (file)
index 0000000..ba86243
--- /dev/null
@@ -0,0 +1,455 @@
+package OpenSRF::System;
+use strict; use warnings;
+use OpenSRF;
+use base 'OpenSRF';
+use OpenSRF::Utils::Logger qw(:level);
+use OpenSRF::Transport::Listener;
+use OpenSRF::Transport;
+use OpenSRF::UnixServer;
+use OpenSRF::Utils;
+use OpenSRF::Utils::LogServer;
+use OpenSRF::EX qw/:try/;
+use POSIX qw/setsid :sys_wait_h/;
+use OpenSRF::Utils::Config; 
+use OpenSRF::Utils::SettingsParser;
+use OpenSRF::Utils::SettingsClient;
+use OpenSRF::Application;
+use Net::Server::PreFork;
+use strict;
+
+my $bootstrap_config_file;
+sub import {
+       my( $self, $config ) = @_;
+       $bootstrap_config_file = $config;
+}
+
+=head2 Name/Description
+
+OpenSRF::System
+
+To start the system: OpenSRF::System->bootstrap();
+
+Simple system process management and automation.  After instantiating the class, simply call
+bootstrap() to launch the system.  Each launched process is stored as a process-id/method-name
+pair in a local hash.  When we receive a SIG{CHILD}, we loop through this hash and relaunch
+any child processes that may have terminated.  
+
+Currently automated processes include launching the internal Unix Servers, launching the inbound 
+connections for each application, and starting the system shell.
+
+
+Note: There should be only one instance of this class
+alive at any given time.  It is designed as a globel process handler and, hence, will cause much
+oddness if you call the bootstrap() method twice or attempt to create two of these by trickery.
+There is a single instance of the class created on the first call to new().  This same instance is 
+returned on subsequent calls to new().
+
+=cut
+
+$| = 1;
+
+sub DESTROY {}
+
+# ----------------------------------------------
+
+$SIG{INT} = sub { instance()->killall(); };
+
+$SIG{HUP} = sub{ instance()->hupall(); };
+
+#$SIG{CHLD} = \&process_automation;
+
+
+{ 
+       # --- 
+       # put $instance in a closure and return it for requests to new()
+       # since there should only be one System instance running
+       # ----- 
+       my $instance;
+       sub instance { return __PACKAGE__->new(); }
+       sub new {
+               my( $class ) = @_;
+
+               if( ! $instance ) {
+                       $class = ref( $class ) || $class;
+                       my $self = {};
+                       $self->{'pid_hash'} = {};
+                       bless( $self, $class );
+                       $instance = $self;
+               }
+               return $instance;
+       }
+}
+
+# ----------------------------------------------
+# Commands to execute at system launch
+
+sub _unixserver {
+       my( $app ) = @_;
+       return "OpenSRF::UnixServer->new( '$app')->serve()";
+}
+
+sub _listener {
+       my( $app ) = @_;
+       return "OpenSRF::Transport::Listener->new( '$app' )->initialize()->listen()";
+}
+
+
+# ----------------------------------------------
+# Boot up the system
+
+sub load_bootstrap_config {
+
+       if(OpenSRF::Utils::Config->current) {
+               return;
+       }
+
+       if(!$bootstrap_config_file) {
+               die "Please provide a bootstrap config file to OpenSRF::System!\n" . 
+                       "use OpenSRF::System qw(/path/to/bootstrap_config);";
+       }
+
+       OpenSRF::Utils::Config->load( config_file => $bootstrap_config_file );
+
+       OpenSRF::Utils::JSON->register_class_hint( name => "OpenSRF::Application", hint => "method", type => "hash" );
+
+       OpenSRF::Transport->message_envelope(  "OpenSRF::Transport::SlimJabber::MessageWrapper" );
+       OpenSRF::Transport::PeerHandle->set_peer_client(  "OpenSRF::Transport::SlimJabber::PeerConnection" );
+       OpenSRF::Transport::Listener->set_listener( "OpenSRF::Transport::SlimJabber::Inbound" );
+       OpenSRF::Application->server_class('client');
+}
+
+sub bootstrap {
+
+       my $self = __PACKAGE__->instance();
+       load_bootstrap_config();
+       OpenSRF::Utils::Logger::set_config();
+       my $bsconfig = OpenSRF::Utils::Config->current;
+
+       # Start a process group and make me the captain
+       exit if (OpenSRF::Utils::safe_fork());
+       chdir('/');
+       setsid(); 
+       close STDIN;
+       close STDOUT;
+       close STDERR;
+
+       $0 = "OpenSRF System";
+
+       # -----------------------------------------------
+       # Launch the settings sever if necessary...
+       my $are_settings_server = 0;
+       if( (my $cfile = $bsconfig->bootstrap->settings_config) ) {
+               my $parser = OpenSRF::Utils::SettingsParser->new();
+
+               # since we're (probably) the settings server, we can go ahead and load the real config file
+               $parser->initialize( $cfile );
+               $OpenSRF::Utils::SettingsClient::host_config = 
+                       $parser->get_server_config($bsconfig->env->hostname);
+
+               my $client = OpenSRF::Utils::SettingsClient->new();
+               my $apps = $client->config_value("activeapps", "appname");
+               if(ref($apps) ne "ARRAY") { $apps = [$apps]; }
+
+               if(!defined($apps) || @$apps == 0) {
+                       print "No apps to load, exiting...";
+                       return;
+               }
+
+               for my $app (@$apps) {
+                       # verify we are a settings server and launch 
+                       if( $app eq "opensrf.settings" and 
+                               $client->config_value("apps","opensrf.settings", "language") =~ /perl/i ) {
+
+                               $are_settings_server = 1;
+                               $self->launch_settings();
+                               sleep 1;
+                               $self->launch_settings_listener();
+                               last;
+                       } 
+               }
+       }
+
+       # Launch everything else
+       OpenSRF::System->bootstrap_client(client_name => "system_client");
+       my $client = OpenSRF::Utils::SettingsClient->new();
+       my $apps = $client->config_value("activeapps", "appname" );
+       if(!ref($apps)) { $apps = [$apps]; }
+
+       if(!defined($apps) || @$apps == 0) {
+               print "No apps to load, exiting...";
+               return;
+       }
+
+       my $server_type = $client->config_value("server_type");
+       $server_type ||= "basic";
+
+       my $con = OpenSRF::Transport::PeerHandle->retrieve;
+       if($con) {
+               $con->disconnect;
+       }
+
+
+
+       if(  $server_type eq "prefork" ) { 
+               $server_type = "Net::Server::PreFork"; 
+       } else { 
+               $server_type = "Net::Server::Single"; 
+       }
+
+       _log( " * Server type: $server_type", INTERNAL );
+
+       $server_type->use;
+
+       if( $@ ) {
+               throw OpenSRF::EX::PANIC ("Cannot set $server_type: $@" );
+       }
+
+       push @OpenSRF::UnixServer::ISA, $server_type;
+
+       _log( " * System bootstrap" );
+       
+       # --- Boot the Unix servers
+       $self->launch_unix($apps);
+
+       sleep 2;
+
+       # --- Boot the listeners
+       $self->launch_listener($apps);
+
+    sleep 1;
+
+       _log( " * System is ready..." );
+
+#      sleep 1;
+#      my $ps = `ps ax | grep " Open" | grep -v grep | sort -r -k5`;
+#      print "\n --- PS --- \n$ps --- PS ---\n\n";
+
+       while( 1 ) { sleep; }
+       exit;
+}
+       
+       
+
+# ----------------------------------------------
+# Bootstraps a single client connection.  
+
+# named params are 'config_file' and 'client_name'
+#
+sub bootstrap_client {
+       my $self = shift;
+
+       my $con = OpenSRF::Transport::PeerHandle->retrieve;
+
+       if($con and $con->tcp_connected) {
+               return;
+       }
+
+       my %params = @_;
+
+       $bootstrap_config_file = 
+               $params{config_file} || $bootstrap_config_file;
+
+       my $app = $params{client_name} || "client";
+
+
+       load_bootstrap_config();
+       OpenSRF::Utils::Logger::set_config();
+       OpenSRF::Transport::PeerHandle->construct( $app );
+
+}
+
+sub connected {
+       if (my $con = OpenSRF::Transport::PeerHandle->retrieve) {
+               return 1 if ($con->tcp_connected);
+       }
+       return 0;
+}
+
+sub bootstrap_logger {
+       $0 = "Log Server";
+       OpenSRF::Utils::LogServer->serve();
+}
+
+
+# ----------------------------------------------
+# Cycle through the known processes, reap the dead child 
+# and put a new child in its place. (MMWWAHAHHAHAAAA!)
+
+sub process_automation {
+
+       my $self = __PACKAGE__->instance();
+
+       foreach my $pid ( keys %{$self->pid_hash} ) {
+
+               if( waitpid( $pid, WNOHANG ) == $pid ) {
+
+                       my $method = $self->pid_hash->{$pid};
+                       delete $self->pid_hash->{$pid};
+
+                       my $newpid =  OpenSRF::Utils::safe_fork();
+
+                       OpenSRF::Utils::Logger->debug( "Relaunching $method", ERROR );
+                       _log( "Relaunching => $method" );
+
+                       if( $newpid ) {
+                               $self->pid_hash( $newpid, $method );
+                       }
+                       else { eval $method; exit; }
+               }
+       }
+
+       $SIG{CHLD} = \&process_automation;
+}
+
+
+
+sub launch_settings {
+
+       #       XXX the $self like this and pid automation will not work with this setup....
+       my($self) = @_;
+       @OpenSRF::UnixServer::ISA = qw(OpenSRF Net::Server::PreFork);
+
+       my $pid = OpenSRF::Utils::safe_fork();
+       if( $pid ) {
+               $self->pid_hash( $pid , "launch_settings()" );
+       }
+       else {
+               my $apname = "opensrf.settings";
+               #$0 = "OpenSRF App [$apname]";
+               eval _unixserver( $apname );
+               if($@) { die "$@\n"; }
+               exit;
+       }
+
+       @OpenSRF::UnixServer::ISA = qw(OpenSRF);
+
+}
+
+
+sub launch_settings_listener {
+
+       my $self = shift;
+       my $app = "opensrf.settings";
+       my $pid = OpenSRF::Utils::safe_fork();
+       if ( $pid ) {
+               $self->pid_hash( $pid , _listener( $app ) );
+       }
+       else {
+               my $apname = $app;
+               $0 = "OpenSRF listener [$apname]";
+               eval _listener( $app );
+               exit;
+       }
+
+}
+
+# ----------------------------------------------
+# Launch the Unix Servers
+
+sub launch_unix {
+       my( $self, $apps ) = @_;
+
+       my $client = OpenSRF::Utils::SettingsClient->new();
+
+       foreach my $app ( @$apps ) {
+
+               next unless $app;
+               my $lang = $client->config_value( "apps", $app, "language");
+               next unless $lang =~ /perl/i;
+               next if $app eq "opensrf.settings";
+
+               _log( " * Starting UnixServer for $app..." );
+
+               my $pid = OpenSRF::Utils::safe_fork();
+               if( $pid ) {
+                       $self->pid_hash( $pid , _unixserver( $app ) );
+               }
+               else {
+                       my $apname = $app;
+                       $0 = "OpenSRF App ($apname)";
+                       eval _unixserver( $app );
+                       exit;
+               }
+       }
+}
+
+# ----------------------------------------------
+# Launch the inbound clients
+
+sub launch_listener {
+
+       my( $self, $apps ) = @_;
+       my $client = OpenSRF::Utils::SettingsClient->new();
+
+       foreach my $app ( @$apps ) {
+
+               next unless $app;
+               my $lang = $client->config_value( "apps", $app, "language");
+               next unless $lang =~ /perl/i;
+               next if $app eq "opensrf.settings";
+
+               _log( " * Starting Listener for $app..." );
+
+               my $pid = OpenSRF::Utils::safe_fork();
+               if ( $pid ) {
+                       $self->pid_hash( $pid , _listener( $app ) );
+               }
+               else {
+                       my $apname = $app;
+                       $0 = "OpenSRF listener [$apname]";
+                       eval _listener( $app );
+                       exit;
+               }
+       }
+}
+
+
+# ----------------------------------------------
+
+sub pid_hash {
+       my( $self, $pid, $method ) = @_;
+       $self->{'pid_hash'}->{$pid} = $method
+               if( $pid and $method );
+       return $self->{'pid_hash'};
+}
+
+# ----------------------------------------------
+# If requested, the System can shut down.
+
+sub killall {
+
+       $SIG{CHLD} = 'IGNORE';
+       $SIG{INT} = 'IGNORE';
+       kill( 'INT', -$$ ); #kill all in process group
+       exit;
+
+}
+
+# ----------------------------------------------
+# Handle $SIG{HUP}
+sub hupall {
+
+       _log( "HUPping brood" );
+       $SIG{CHLD} = 'IGNORE';
+       $SIG{HUP} = 'IGNORE';
+       kill( 'HUP', -$$ );
+#      $SIG{CHLD} = \&process_automation;
+       $SIG{HUP} = sub{ instance()->hupall(); };
+}
+
+
+# ----------------------------------------------
+# Log to debug, and stdout
+
+sub _log {
+       my $string = shift;
+       OpenSRF::Utils::Logger->debug( $string, INFO );
+       print $string . "\n";
+}
+
+# ----------------------------------------------
+
+
+1;
+
+
diff --git a/src/perl/lib/OpenSRF/Transport.pm b/src/perl/lib/OpenSRF/Transport.pm
new file mode 100644 (file)
index 0000000..69e803e
--- /dev/null
@@ -0,0 +1,198 @@
+package OpenSRF::Transport;
+use strict; use warnings;
+use base 'OpenSRF';
+use Time::HiRes qw/time/;
+use OpenSRF::AppSession;
+use OpenSRF::Utils::JSON;
+use OpenSRF::Utils::Logger qw(:level);
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use OpenSRF::EX qw/:try/;
+use OpenSRF::Transport::SlimJabber::MessageWrapper;
+
+#------------------ 
+# --- These must be implemented by all Transport subclasses
+# -------------------------------------------
+
+=head2 get_listener
+
+Returns the package name of the package the system will use to 
+gather incoming requests
+
+=cut
+
+sub get_listener { shift()->alert_abstract(); }
+
+=head2 get_peer_client
+
+Returns the name of the package responsible for client communication
+
+=cut
+
+sub get_peer_client { shift()->alert_abstract(); } 
+
+=head2 get_msg_envelope
+
+Returns the name of the package responsible for parsing incoming messages
+
+=cut
+
+sub get_msg_envelope { shift()->alert_abstract(); } 
+
+# -------------------------------------------
+
+our $message_envelope;
+my $logger = "OpenSRF::Utils::Logger"; 
+
+
+
+=head2 message_envelope( [$envelope] );
+
+Sets the message envelope class that will allow us to extract
+information from the messages we receive from the low 
+level transport
+
+=cut
+
+sub message_envelope {
+       my( $class, $envelope ) = @_;
+       if( $envelope ) {
+               $message_envelope = $envelope;
+               $envelope->use;
+               if( $@ ) {
+                       $logger->error( 
+                                       "Error loading message_envelope: $envelope -> $@", ERROR);
+               }
+       }
+       return $message_envelope;
+}
+
+=head2 handler( $data )
+
+Creates a new MessageWrapper, extracts the remote_id, session_id, and message body
+from the message.  Then, creates or retrieves the AppSession object with the session_id and remote_id. 
+Finally, creates the message document from the body of the message and calls
+the handler method on the message document.
+
+=cut
+
+sub handler {
+       my $start_time = time();
+       my( $class, $service, $data ) = @_;
+
+       $logger->transport( "Transport handler() received $data", INTERNAL );
+
+       my $remote_id   = $data->from;
+       my $sess_id     = $data->thread;
+       my $body        = $data->body;
+       my $type        = $data->type;
+
+       $logger->set_osrf_xid($data->osrf_xid);
+
+
+       if (defined($type) and $type eq 'error') {
+               throw OpenSRF::EX::Session ("$remote_id IS NOT CONNECTED TO THE NETWORK!!!");
+
+       }
+
+       # See if the app_session already exists.  If so, make 
+       # sure the sender hasn't changed if we're a server
+       my $app_session = OpenSRF::AppSession->find( $sess_id );
+       if( $app_session and $app_session->endpoint == $app_session->SERVER() and
+                       $app_session->remote_id ne $remote_id ) {
+
+           my $c = OpenSRF::Utils::SettingsClient->new();
+        if($c->config_value("apps", $app_session->service, "migratable")) {
+            $logger->debug("service is migratable, new client is $remote_id");
+        } else {
+
+                   $logger->warn("Backend Gone or invalid sender");
+                   my $res = OpenSRF::DomainObject::oilsBrokenSession->new();
+                   $res->status( "Backend Gone or invalid sender, Reconnect" );
+                   $app_session->status( $res );
+                   return 1;
+        }
+       } 
+
+       # Retrieve or build the app_session as appropriate (server_build decides which to do)
+       $logger->transport( "AppSession is valid or does not exist yet", INTERNAL );
+       $app_session = OpenSRF::AppSession->server_build( $sess_id, $remote_id, $service );
+
+       if( ! $app_session ) {
+               throw OpenSRF::EX::Session ("Transport::handler(): No AppSession object returned from server_build()");
+       }
+
+       # Create a document from the JSON contained within the message 
+       my $doc; 
+       eval { $doc = OpenSRF::Utils::JSON->JSON2perl($body); };
+       if( $@ ) {
+
+               $logger->warn("Received bogus JSON: $@");
+               $logger->warn("Bogus JSON data: $body");
+               my $res = OpenSRF::DomainObject::oilsXMLParseError->new( status => "JSON Parse Error --- $body\n\n$@" );
+
+               $app_session->status($res);
+               #$app_session->kill_me;
+               return 1;
+       }
+
+       $logger->transport( "Transport::handler() creating \n$body", INTERNAL );
+
+       # We need to disconnect the session if we got a jabber error on the client side.  For
+       # server side, we'll just tear down the session and go away.
+       if (defined($type) and $type eq 'error') {
+               # If we're a server
+               if( $app_session->endpoint == $app_session->SERVER() ) {
+                       $app_session->kill_me;
+                       return 1;
+               } else {
+                       $app_session->reset;
+                       $app_session->state( $app_session->DISCONNECTED );
+                       # below will lead to infinite looping, should return an exception
+                       #$app_session->push_resend( $app_session->app_request( 
+                       #               $doc->documentElement->firstChild->threadTrace ) );
+                       $logger->debug(
+                               "Got Jabber error on client connection $remote_id, nothing we can do..", ERROR );
+                       return 1;
+               }
+       }
+
+       # cycle through and pass each oilsMessage contained in the message
+       # up to the message layer for processing.
+       for my $msg (@$doc) {
+
+               next unless (   $msg && UNIVERSAL::isa($msg => 'OpenSRF::DomainObject::oilsMessage'));
+
+               if( $app_session->endpoint == $app_session->SERVER() ) {
+
+                       try {  
+
+                               if( ! $msg->handler( $app_session ) ) { return 0; }
+
+                               $logger->debug("Successfully handled message", DEBUG);
+
+                       } catch Error with {
+
+                               my $e = shift;
+                               my $res = OpenSRF::DomainObject::oilsServerError->new();
+                               $res->status( $res->status . "\n$e");
+                               $app_session->status($res) if $res;
+                               $app_session->kill_me;
+                               return 0;
+
+                       };
+
+               } else { 
+
+                       if( ! $msg->handler( $app_session ) ) { return 0; } 
+                       $logger->info("Successfully handled message", DEBUG);
+
+               }
+
+       }
+
+       $logger->debug(sprintf("Message processing duration: %.3fs",(time() - $start_time)), DEBUG);
+
+       return $app_session;
+}
+
+1;
diff --git a/src/perl/lib/OpenSRF/Transport/Listener.pm b/src/perl/lib/OpenSRF/Transport/Listener.pm
new file mode 100644 (file)
index 0000000..c3496b1
--- /dev/null
@@ -0,0 +1,45 @@
+package OpenSRF::Transport::Listener;
+use base 'OpenSRF';
+use OpenSRF::Utils::Logger qw(:level);
+use OpenSRF::Transport::SlimJabber::Inbound;
+use base 'OpenSRF::Transport::SlimJabber::Inbound';
+
+=head1 Description
+
+This is the empty class that acts as the subclass of the transport listener.  My API
+includes
+
+new( $app )
+       create a new Listener with appname $app
+
+initialize()
+       Perform any transport layer connections/authentication.
+
+listen()
+       Block, wait for, and process incoming messages
+
+=cut
+
+=head2 set_listener()
+
+Sets my superclass.  Pass in a string representing the perl module
+(e.g. OpenSRF::Transport::Jabber::JInbound) to be used as the
+superclass and it will be pushed onto @ISA.
+
+=cut
+
+sub set_listener {
+       my( $class, $listener ) = @_;
+       OpenSRF::Utils::Logger->transport("Loading Listener $listener", INFO );
+       if( $listener ) {
+               $listener->use;
+               if( $@ ) {
+                       OpenSRF::Utils::Logger->error(
+                                       "Unable to set transport listener: $@", ERROR );
+               }
+               unshift @ISA, $listener;
+       }
+}
+
+
+1;
diff --git a/src/perl/lib/OpenSRF/Transport/PeerHandle.pm b/src/perl/lib/OpenSRF/Transport/PeerHandle.pm
new file mode 100644 (file)
index 0000000..e263971
--- /dev/null
@@ -0,0 +1,40 @@
+package OpenSRF::Transport::PeerHandle;
+use OpenSRF::Utils::Logger qw(:level);
+use OpenSRF::EX;
+use base qw/OpenSRF::Transport::SlimJabber::PeerConnection/;
+use vars '@ISA';
+
+my $peer;
+
+=head2 peer_handle( $handle )
+
+Assigns the object that will act as the peer connection handle.
+
+=cut
+sub peer_handle {
+       my( $class, $handle ) = @_;
+       if( $handle ) { $peer = $handle; }
+       return $peer;
+}
+
+
+=head2 set_peer_client( $peer )
+
+Sets the class that will act as the superclass of this class.
+Pass in a string representing the module to be used as the superclass,
+and that module is 'used' and unshifted into @ISA.  We now have that
+classes capabilities.  
+
+=cut
+sub set_peer_client {
+       my( $class, $peer ) = @_;
+       if( $peer ) {
+               $peer->use;
+               if( $@ ) {
+                       throw OpenSRF::EX::PANIC ( "Unable to set peer client: $@" );
+               }
+               unshift @ISA, $peer;
+       }
+}
+
+1;
diff --git a/src/perl/lib/OpenSRF/Transport/SlimJabber.pm b/src/perl/lib/OpenSRF/Transport/SlimJabber.pm
new file mode 100644 (file)
index 0000000..7963b93
--- /dev/null
@@ -0,0 +1,18 @@
+package OpenSRF::Transport::SlimJabber;
+use base qw/OpenSRF::Transport/;
+
+=head2 OpenSRF::Transport::SlimJabber
+
+Implements the Transport interface for providing the system with appropriate
+classes for handling transport layer messaging
+
+=cut
+
+
+sub get_listener { return "OpenSRF::Transport::SlimJabber::Inbound"; }
+
+sub get_peer_client { return "OpenSRF::Transport::SlimJabber::PeerConnection"; }
+
+sub get_msg_envelope { return "OpenSRF::Transport::SlimJabber::MessageWrapper"; }
+
+1;
diff --git a/src/perl/lib/OpenSRF/Transport/SlimJabber/Client.pm b/src/perl/lib/OpenSRF/Transport/SlimJabber/Client.pm
new file mode 100644 (file)
index 0000000..ed3d5a0
--- /dev/null
@@ -0,0 +1,204 @@
+package OpenSRF::Transport::SlimJabber::Client;
+
+use strict;
+use warnings;
+
+use OpenSRF::EX;
+use OpenSRF::Utils::Config;
+use OpenSRF::Utils::Logger qw/$logger/;
+use OpenSRF::Transport::SlimJabber::XMPPReader;
+use OpenSRF::Transport::SlimJabber::XMPPMessage;
+use IO::Socket::UNIX;
+use FreezeThaw qw/freeze/;
+
+sub DESTROY{
+    shift()->disconnect;
+}
+
+=head1 NAME
+
+OpenSRF::Transport::SlimJabber::Client
+
+=head1 SYNOPSIS
+
+
+
+=head1 DESCRIPTION
+
+
+
+=cut
+
+=head1 METHODS
+
+=head2 new
+
+=cut
+
+sub new {
+       my( $class, %params ) = @_;
+    my $self = bless({}, ref($class) || $class);
+    $self->params(\%params);
+       return $self;
+}
+
+=head2 reader
+
+=cut
+
+sub reader {
+    my($self, $reader) = @_;
+    $self->{reader} = $reader if $reader;
+    return $self->{reader};
+}
+
+=head2 params
+
+=cut
+
+sub params {
+    my($self, $params) = @_;
+    $self->{params} = $params if $params;
+    return $self->{params};
+}
+
+=head2 socket
+
+=cut
+
+sub socket {
+    my($self, $socket) = @_;
+    $self->{socket} = $socket if $socket;
+    return $self->{socket};
+}
+
+=head2 disconnect
+
+=cut
+
+sub disconnect {
+    my $self = shift;
+       $self->reader->disconnect if $self->reader;
+}
+
+
+=head2 gather
+
+=cut
+
+sub gather { 
+    my $self = shift; 
+    $self->process( 0 ); 
+}
+
+# -------------------------------------------------
+
+=head2 tcp_connected
+
+=cut
+
+sub tcp_connected {
+       my $self = shift;
+    return $self->reader->tcp_connected if $self->reader;
+    return 0;
+}
+
+
+
+=head2 send
+
+=cut
+
+sub send {
+       my $self = shift;
+    my $msg = OpenSRF::Transport::SlimJabber::XMPPMessage->new(@_);
+    $self->reader->send($msg->to_xml);
+}
+
+=head2 initialize
+
+=cut
+
+sub initialize {
+
+       my $self = shift;
+
+       my $host        = $self->params->{host}; 
+       my $port        = $self->params->{port}; 
+       my $username    = $self->params->{username};
+       my $resource    = $self->params->{resource};
+       my $password    = $self->params->{password};
+
+    my $jid = "$username\@$host/$resource";
+
+       my $conf = OpenSRF::Utils::Config->current;
+
+       my $tail = "_$$";
+       $tail = "" if !$conf->bootstrap->router_name and $username eq "router";
+    $resource = "$resource$tail";
+
+    my $socket = IO::Socket::INET->new(
+        PeerHost => $host,
+        PeerPort => $port,
+        Peer => $port,
+        Proto  => 'tcp' );
+
+    throw OpenSRF::EX::Jabber("Could not open TCP socket to Jabber server: $!")
+           unless ( $socket and $socket->connected );
+
+    $self->socket($socket);
+    $self->reader(OpenSRF::Transport::SlimJabber::XMPPReader->new($socket));
+    $self->reader->connect($host, $username, $password, $resource);
+
+    throw OpenSRF::EX::Jabber("Could not authenticate with Jabber server: $!")
+           unless ( $self->reader->connected );
+
+       return $self;
+}
+
+
+=head2 construct
+
+=cut
+
+sub construct {
+       my( $class, $app ) = @_;
+       $class->peer_handle($class->new( $app )->initialize());
+}
+
+
+=head2 process
+
+=cut
+
+sub process {
+       my($self, $timeout) = @_;
+
+       $timeout ||= 0;
+    $timeout = int($timeout);
+
+       unless( $self->reader and $self->reader->connected ) {
+        throw OpenSRF::EX::JabberDisconnected 
+            ("This JabberClient instance is no longer connected to the server ");
+       }
+
+    return $self->reader->wait_msg($timeout);
+}
+
+
+=head2 flush_socket
+
+Sets the socket to O_NONBLOCK, reads all of the data off of the
+socket, the restores the sockets flags.  Returns 1 on success, 0 if
+the socket isn't connected.
+
+=cut
+
+sub flush_socket {
+       my $self = shift;
+    return $self->reader->flush_socket;
+}
+
+1;
+
+
diff --git a/src/perl/lib/OpenSRF/Transport/SlimJabber/Inbound.pm b/src/perl/lib/OpenSRF/Transport/SlimJabber/Inbound.pm
new file mode 100644 (file)
index 0000000..9194927
--- /dev/null
@@ -0,0 +1,165 @@
+package OpenSRF::Transport::SlimJabber::Inbound;
+use strict;use warnings;
+use base qw/OpenSRF::Transport::SlimJabber::Client/;
+use OpenSRF::EX qw(:try);
+use OpenSRF::Utils::Logger qw(:level);
+use OpenSRF::Utils::SettingsClient;
+use OpenSRF::Utils::Config;
+use Time::HiRes qw/usleep/;
+use FreezeThaw qw/freeze/;
+
+my $logger = "OpenSRF::Utils::Logger";
+
+=head1 Description
+
+This is the jabber connection where all incoming client requests will be accepted.
+This connection takes the data, passes it off to the system then returns to take
+more data.  Connection params are all taken from the config file and the values
+retreived are based on the $app name passed into new().
+
+This service should be loaded at system startup.
+
+=cut
+
+{
+       my $unix_sock;
+       sub unix_sock { return $unix_sock; }
+       my $instance;
+
+       sub new {
+               my( $class, $app ) = @_;
+               $class = ref( $class ) || $class;
+               if( ! $instance ) {
+
+                       my $conf = OpenSRF::Utils::Config->current;
+                       my $domain = $conf->bootstrap->domain;
+            $logger->error("use of <domains/> is deprecated") if $conf->bootstrap->domains;
+
+                       my $username    = $conf->bootstrap->username;
+                       my $password    = $conf->bootstrap->passwd;
+                       my $port                        = $conf->bootstrap->port;
+                       my $host                        = $domain;
+                       my $resource    = $app . '_listener_at_' . $conf->env->hostname;
+
+                       my $router_name = $conf->bootstrap->router_name;
+                       # no router, only one listener running..
+                       if(!$router_name) { 
+                               $username = "router";
+                               $resource = $app; 
+                       }
+
+                       OpenSRF::Utils::Logger->transport("Inbound as $username, $password, $resource, $host, $port\n", INTERNAL );
+
+                       my $self = __PACKAGE__->SUPER::new( 
+                                       username                => $username,
+                                       resource                => $resource,
+                                       password                => $password,
+                                       host                    => $host,
+                                       port                    => $port,
+                                       );
+
+                       $self->{app} = $app;
+                                       
+                       my $client = OpenSRF::Utils::SettingsClient->new();
+                       my $f = $client->config_value("dirs", "sock");
+                       $unix_sock = join( "/", $f, 
+                                       $client->config_value("apps", $app, "unix_config", "unix_sock" ));
+                       bless( $self, $class );
+                       $instance = $self;
+               }
+               return $instance;
+       }
+
+}
+
+sub DESTROY {
+       my $self = shift;
+       for my $router (@{$self->{routers}}) {
+               if($self->tcp_connected()) {
+            $logger->info("disconnecting from router $router");
+                       $self->send( to => $router, body => "registering", 
+                               router_command => "unregister" , router_class => $self->{app} );
+               }
+       }
+}
+       
+sub listen {
+       my $self = shift;
+       
+    $self->{routers} = [];
+
+       try {
+
+               my $conf = OpenSRF::Utils::Config->current;
+        my $router_name = $conf->bootstrap->router_name;
+               my $routers = $conf->bootstrap->routers;
+        $logger->info("loading router info $routers");
+
+        for my $router (@$routers) {
+            if(ref $router) {
+                if( !$router->{services} || grep { $_ eq $self->{app} } @{$router->{services}->{service}} ) {
+                    my $name = $router->{name};
+                    my $domain = $router->{domain};
+                    my $target = "$name\@$domain/router";
+                    push(@{$self->{routers}}, $target);
+                    $logger->info( $self->{app} . " connecting to router $target");
+                    $self->send( to => $target, body => "registering", router_command => "register" , router_class => $self->{app} );
+                }
+            } else {
+                my $target = "$router_name\@$router/router";
+                push(@{$self->{routers}}, $target);
+                $logger->info( $self->{app} . " connecting to router $target");
+                $self->send( to => $target, body => "registering", router_command => "register" , router_class => $self->{app} );
+            }
+        }
+               
+       } catch Error with {
+               $logger->transport( $self->{app} . ": No routers defined" , WARN ); 
+               # no routers defined
+       };
+
+
+       
+                       
+       $logger->transport( $self->{app} . " going into listen loop", INFO );
+
+       while(1) {
+       
+               my $sock = $self->unix_sock();
+               my $o;
+
+               $logger->debug("Inbound listener calling process()");
+
+               try {
+                       $o = $self->process(-1);
+
+                       if(!$o){
+                               $logger->error(
+                                       "Inbound received no data from the Jabber socket in process()");
+                               usleep(100000); # otherwise we loop and pound syslog logger with errors
+                       }
+
+               } catch OpenSRF::EX::JabberDisconnected with {
+
+                       $logger->error("Inbound process lost its ".
+                               "jabber connection.  Attempting to reconnect...");
+                       $self->initialize;
+                       $o = undef;
+               };
+
+
+               if($o) {
+                       my $socket = IO::Socket::UNIX->new( Peer => $sock  );
+                       throw OpenSRF::EX::Socket( 
+                               "Unable to connect to UnixServer: socket-file: $sock \n :=> $! " )
+                               unless ($socket->connected);
+                       print $socket freeze($o);
+                       $socket->close;
+               } 
+       }
+
+       throw OpenSRF::EX::Socket( "How did we get here?!?!" );
+}
+
+1;
+
diff --git a/src/perl/lib/OpenSRF/Transport/SlimJabber/MessageWrapper.pm b/src/perl/lib/OpenSRF/Transport/SlimJabber/MessageWrapper.pm
new file mode 100644 (file)
index 0000000..0fa95c5
--- /dev/null
@@ -0,0 +1,72 @@
+package OpenSRF::Transport::SlimJabber::MessageWrapper;
+use strict; use warnings;
+use OpenSRF::Transport::SlimJabber::XMPPMessage;
+
+# ----------------------------------------------------------
+# Legacy wrapper for XMPPMessage
+# ----------------------------------------------------------
+
+sub new {
+       my $class = shift;
+    my $msg = shift;
+    return bless({msg => $msg}, ref($class) || $class);
+}
+
+sub msg {
+    my($self, $msg) = @_;
+    $self->{msg} = $msg if $msg;
+    return $self->{msg};
+}
+
+sub toString {
+    return $_[0]->msg->to_xml;
+}
+
+sub get_body {
+    return $_[0]->msg->body;
+}
+
+sub get_sess_id {
+    return $_[0]->msg->thread;
+}
+
+sub get_msg_type {
+    return $_[0]->msg->type;
+}
+
+sub get_remote_id {
+    return $_[0]->msg->from;
+}
+
+sub setType {
+    $_[0]->msg->type(shift());
+}
+
+sub setTo {
+    $_[0]->msg->to(shift());
+}
+
+sub setThread {
+    $_[0]->msg->thread(shift());
+}
+
+sub setBody {
+    $_[0]->msg->body(shift());
+}
+
+sub set_router_command {
+    $_[0]->msg->router_command(shift());
+}
+sub set_router_class {
+    $_[0]->msg->router_class(shift());
+}
+
+sub set_osrf_xid {
+    $_[0]->msg->osrf_xid(shift());
+}
+
+sub get_osrf_xid {
+   return $_[0]->msg->osrf_xid;
+}
+
+1;
diff --git a/src/perl/lib/OpenSRF/Transport/SlimJabber/PeerConnection.pm b/src/perl/lib/OpenSRF/Transport/SlimJabber/PeerConnection.pm
new file mode 100644 (file)
index 0000000..7c59456
--- /dev/null
@@ -0,0 +1,99 @@
+package OpenSRF::Transport::SlimJabber::PeerConnection;
+use strict;
+use base qw/OpenSRF::Transport::SlimJabber::Client/;
+use OpenSRF::Utils::Config;
+use OpenSRF::Utils::Logger qw(:level);
+use OpenSRF::EX qw/:try/;
+
+=head1 Description
+
+Represents a single connection to a remote peer.  The 
+Jabber values are loaded from the config file.  
+
+Subclasses OpenSRF::Transport::SlimJabber::Client.
+
+=cut
+
+=head2 new()
+
+       new( $appname );
+
+       The $appname parameter tells this class how to find the correct
+       Jabber username, password, etc to connect to the server.
+
+=cut
+
+our %apps_hash;
+our $_singleton_connection;
+
+sub retrieve { 
+       my( $class, $app ) = @_;
+       return $_singleton_connection;
+}
+
+
+sub new {
+       my( $class, $app ) = @_;
+
+       my $peer_con = $class->retrieve;
+       return $peer_con if ($peer_con and $peer_con->tcp_connected);
+
+       my $config = OpenSRF::Utils::Config->current;
+
+       if( ! $config ) {
+               throw OpenSRF::EX::Config( "No suitable config found for PeerConnection" );
+       }
+
+       my $conf                        = OpenSRF::Utils::Config->current;
+       my $domain = $conf->bootstrap->domain;
+       my $h = $conf->env->hostname;
+       OpenSRF::Utils::Logger->error("use of <domains/> is deprecated") if $conf->bootstrap->domains;
+
+       my $username    = $conf->bootstrap->username;
+       my $password    = $conf->bootstrap->passwd;
+       my $port        = $conf->bootstrap->port;
+       my $resource    = "${app}_drone_at_$h";
+       my $host        = $domain; # XXX for now...
+
+       if( $app eq "client" ) { $resource = "client_at_$h"; }
+
+       OpenSRF::EX::Config->throw( "JPeer could not load all necesarry values from config" )
+               unless ( $username and $password and $resource and $host and $port );
+
+       OpenSRF::Utils::Logger->transport( "Built Peer with", INTERNAL );
+
+       my $self = __PACKAGE__->SUPER::new( 
+               username                => $username,
+               resource                => $resource,
+               password                => $password,
+               host                    => $host,
+               port                    => $port,
+               );      
+                                       
+       bless( $self, $class );
+
+       $self->app($app);
+
+       $_singleton_connection = $self;
+       $apps_hash{$app} = $self;
+
+       return $_singleton_connection;
+       return $apps_hash{$app};
+}
+
+sub process {
+       my $self = shift;
+       my $val = $self->SUPER::process(@_);
+       return 0 unless $val;
+       return OpenSRF::Transport->handler($self->app, $val);
+}
+
+sub app {
+       my $self = shift;
+       my $app = shift;
+       $self->{app} = $app if $app;
+       return $self->{app};
+}
+
+1;
+
diff --git a/src/perl/lib/OpenSRF/Transport/SlimJabber/XMPPMessage.pm b/src/perl/lib/OpenSRF/Transport/SlimJabber/XMPPMessage.pm
new file mode 100644 (file)
index 0000000..9bd5328
--- /dev/null
@@ -0,0 +1,134 @@
+package OpenSRF::Transport::SlimJabber::XMPPMessage;
+use strict; use warnings;
+use OpenSRF::Utils::Logger qw/$logger/;
+use OpenSRF::EX qw/:try/;
+use strict; use warnings;
+use XML::LibXML;
+
+use constant JABBER_MESSAGE =>
+    "<message to='%s' from='%s' router_command='%s' router_class='%s' osrf_xid='%s'>".
+    "<thread>%s</thread><body>%s</body></message>";
+
+sub new {
+    my $class = shift;
+    my %args = @_;
+    my $self = bless({}, $class);
+
+    if($args{xml}) {
+        $self->parse_xml($args{xml});
+
+    } else {
+        $self->{to} = $args{to} || '';
+        $self->{from} = $args{from} || '';
+        $self->{thread} = $args{thread} || '';
+        $self->{body} = $args{body} || '';
+        $self->{osrf_xid} = $args{osrf_xid} || '';
+        $self->{router_command} = $args{router_command} || '';
+        $self->{router_class} = $args{router_class} || '';
+    }
+
+    return $self;
+}
+
+sub to {
+    my($self, $to) = @_;
+    $self->{to} = $to if defined $to;
+    return $self->{to};
+}
+sub from {
+    my($self, $from) = @_;
+    $self->{from} = $from if defined $from;
+    return $self->{from};
+}
+sub thread {
+    my($self, $thread) = @_;
+    $self->{thread} = $thread if defined $thread;
+    return $self->{thread};
+}
+sub body {
+    my($self, $body) = @_;
+    $self->{body} = $body if defined $body;
+    return $self->{body};
+}
+sub status {
+    my($self, $status) = @_;
+    $self->{status} = $status if defined $status;
+    return $self->{status};
+}
+sub type {
+    my($self, $type) = @_;
+    $self->{type} = $type if defined $type;
+    return $self->{type};
+}
+sub err_type {
+    my($self, $err_type) = @_;
+    $self->{err_type} = $err_type if defined $err_type;
+    return $self->{err_type};
+}
+sub err_code {
+    my($self, $err_code) = @_;
+    $self->{err_code} = $err_code if defined $err_code;
+    return $self->{err_code};
+}
+sub osrf_xid {
+    my($self, $osrf_xid) = @_;
+    $self->{osrf_xid} = $osrf_xid if defined $osrf_xid;
+    return $self->{osrf_xid};
+}
+sub router_command {
+    my($self, $router_command) = @_;
+    $self->{router_command} = $router_command if defined $router_command;
+    return $self->{router_command};
+}
+sub router_class {
+    my($self, $router_class) = @_;
+    $self->{router_class} = $router_class if defined $router_class;
+    return $self->{router_class};
+}
+
+
+sub to_xml {
+    my $self = shift;
+
+    my $body = $self->{body};
+    $body =~ s/&/&amp;/sog;
+    $body =~ s/</&lt;/sog;
+    $body =~ s/>/&gt;/sog;
+
+    return sprintf(
+        JABBER_MESSAGE,
+        $self->{to},
+        $self->{from},
+        $self->{router_command},
+        $self->{router_class},
+        $self->{osrf_xid},
+        $self->{thread},
+        $body
+    );
+}
+
+sub parse_xml {
+    my($self, $xml) = @_;
+    my($doc, $err);
+
+    try {
+        $doc = XML::LibXML->new->parse_string($xml);
+    } catch Error with {
+        my $err = shift;
+        $logger->error("Error parsing message xml: $xml --- $err");
+    };
+    throw $err if $err;
+
+    my $root = $doc->documentElement;
+
+    $self->{body} = $root->findnodes('/message/body').'';
+    $self->{thread} = $root->findnodes('/message/thread').'';
+    $self->{from} = $root->getAttribute('router_from');
+    $self->{from} = $root->getAttribute('from') unless $self->{from};
+    $self->{to} = $root->getAttribute('to');
+    $self->{type} = $root->getAttribute('type');
+    $self->{osrf_xid} = $root->getAttribute('osrf_xid');
+}
+
+
+1;
diff --git a/src/perl/lib/OpenSRF/Transport/SlimJabber/XMPPReader.pm b/src/perl/lib/OpenSRF/Transport/SlimJabber/XMPPReader.pm
new file mode 100644 (file)
index 0000000..086a7a6
--- /dev/null
@@ -0,0 +1,352 @@
+package OpenSRF::Transport::SlimJabber::XMPPReader;
+use strict; use warnings;
+use XML::Parser;
+use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
+use Time::HiRes qw/time/;
+use OpenSRF::Transport::SlimJabber::XMPPMessage;
+use OpenSRF::Utils::Logger qw/$logger/;
+
+# -----------------------------------------------------------
+# Connect, disconnect, and authentication messsage templates
+# -----------------------------------------------------------
+use constant JABBER_CONNECT =>
+    "<stream:stream to='%s' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams'>";
+
+use constant JABBER_BASIC_AUTH =>
+    "<iq id='123' type='set'><query xmlns='jabber:iq:auth'>" .
+    "<username>%s</username><password>%s</password><resource>%s</resource></query></iq>";
+
+use constant JABBER_DISCONNECT => "</stream:stream>";
+
+
+# -----------------------------------------------------------
+# XMPP Stream states
+# -----------------------------------------------------------
+use constant DISCONNECTED   => 1;
+use constant CONNECT_RECV   => 2;
+use constant CONNECTED      => 3;
+
+
+# -----------------------------------------------------------
+# XMPP Message states
+# -----------------------------------------------------------
+use constant IN_NOTHING => 1;
+use constant IN_BODY    => 2;
+use constant IN_THREAD  => 3;
+use constant IN_STATUS  => 4;
+
+
+# -----------------------------------------------------------
+# Constructor, getter/setters
+# -----------------------------------------------------------
+sub new {
+    my $class = shift;
+    my $socket = shift;
+
+    my $self = bless({}, $class);
+
+    $self->{queue} = [];
+    $self->{stream_state} = DISCONNECTED;
+    $self->{xml_state} = IN_NOTHING;
+    $self->socket($socket);
+
+    my $p = new XML::Parser(Handlers => {
+        Start => \&start_element,
+        End   => \&end_element,
+        Char  => \&characters,
+    });
+
+    $self->parser($p->parse_start); # create a push parser
+    $self->parser->{_parent_} = $self;
+    $self->{message} = OpenSRF::Transport::SlimJabber::XMPPMessage->new;
+    return $self;
+}
+
+sub push_msg {
+    my($self, $msg) = @_; 
+    push(@{$self->{queue}}, $msg) if $msg;
+}
+
+sub next_msg {
+    my $self = shift;
+    return shift @{$self->{queue}};
+}
+
+sub peek_msg {
+    my $self = shift;
+    return (@{$self->{queue}} > 0);
+}
+
+sub parser {
+    my($self, $parser) = @_;
+    $self->{parser} = $parser if $parser;
+    return $self->{parser};
+}
+
+sub socket {
+    my($self, $socket) = @_;
+    $self->{socket} = $socket if $socket;
+    return $self->{socket};
+}
+
+sub stream_state {
+    my($self, $stream_state) = @_;
+    $self->{stream_state} = $stream_state if $stream_state;
+    return $self->{stream_state};
+}
+
+sub xml_state {
+    my($self, $xml_state) = @_;
+    $self->{xml_state} = $xml_state if $xml_state;
+    return $self->{xml_state};
+}
+
+sub message {
+    my($self, $message) = @_;
+    $self->{message} = $message if $message;
+    return $self->{message};
+}
+
+
+# -----------------------------------------------------------
+# Stream and connection handling methods
+# -----------------------------------------------------------
+
+sub connect {
+    my($self, $domain, $username, $password, $resource) = @_;
+    
+    $self->send(sprintf(JABBER_CONNECT, $domain));
+    $self->wait(10);
+
+    unless($self->{stream_state} == CONNECT_RECV) {
+        $logger->error("No initial XMPP response from server");
+        return 0;
+    }
+
+    $self->send(sprintf(JABBER_BASIC_AUTH, $username, $password, $resource));
+    $self->wait(10);
+
+    unless($self->connected) {
+        $logger->error('XMPP connect failed');
+        return 0;
+    }
+
+    return 1;
+}
+
+sub disconnect {
+    my $self = shift;
+    if($self->tcp_connected) {
+        $self->send(JABBER_DISCONNECT); 
+        shutdown($self->socket, 2);
+    }
+    close($self->socket);
+}
+
+# -----------------------------------------------------------
+# returns true if this stream is connected to the server
+# -----------------------------------------------------------
+sub connected {
+    my $self = shift;
+    return ($self->tcp_connected and $self->{stream_state} == CONNECTED);
+}
+
+# -----------------------------------------------------------
+# returns true if the socket is connected
+# -----------------------------------------------------------
+sub tcp_connected {
+    my $self = shift;
+    return ($self->socket and $self->socket->connected);
+}
+
+# -----------------------------------------------------------
+# sends pre-formated XML
+# -----------------------------------------------------------
+sub send {
+    my($self, $xml) = @_;
+    $self->{socket}->print($xml);
+}
+
+# -----------------------------------------------------------
+# Puts a file handle into blocking mode
+# -----------------------------------------------------------
+sub set_block {
+    my $fh = shift;
+    my  $flags = fcntl($fh, F_GETFL, 0);
+    $flags &= ~O_NONBLOCK;
+    fcntl($fh, F_SETFL, $flags);
+}
+
+
+# -----------------------------------------------------------
+# Puts a file handle into non-blocking mode
+# -----------------------------------------------------------
+sub set_nonblock {
+    my $fh = shift;
+    my  $flags = fcntl($fh, F_GETFL, 0);
+    fcntl($fh, F_SETFL, $flags | O_NONBLOCK);
+}
+
+
+sub wait {
+    my($self, $timeout) = @_;
+     
+    return $self->next_msg if $self->peek_msg;
+
+    $timeout ||= 0;
+    $timeout = undef if $timeout < 0;
+    my $socket = $self->{socket};
+
+    set_block($socket);
+    
+    # build the select readset
+    my $infile = '';
+    vec($infile, $socket->fileno, 1) = 1;
+    return undef unless select($infile, undef, undef, $timeout);
+
+    # now slurp the data off the socket
+    my $buf;
+    my $read_size = 1024;
+    while(my $n = sysread($socket, $buf, $read_size)) {
+        $self->{parser}->parse_more($buf) if $buf;
+        if($n < $read_size or $self->peek_msg) {
+            set_block($socket);
+            last;
+        }
+        set_nonblock($socket);
+    }
+
+    return $self->next_msg;
+}
+
+# -----------------------------------------------------------
+# Waits up to timeout seconds for a fully-formed XMPP
+# message to arrive.  If timeout is < 0, waits indefinitely
+# -----------------------------------------------------------
+sub wait_msg {
+    my($self, $timeout) = @_;
+    my $xml;
+
+    $timeout = 0 unless defined $timeout;
+
+    if($timeout < 0) {
+        while(1) {
+            return $xml if $xml = $self->wait($timeout); 
+        }
+
+    } else {
+        while($timeout >= 0) {
+            my $start = time;
+            return $xml if $xml = $self->wait($timeout); 
+            $timeout -= time - $start;
+        }
+    }
+
+    return undef;
+}
+
+
+# -----------------------------------------------------------
+# SAX Handlers
+# -----------------------------------------------------------
+
+
+sub start_element {
+    my($parser, $name, %attrs) = @_;
+    my $self = $parser->{_parent_};
+
+    if($name eq 'message') {
+
+        my $msg = $self->{message};
+        $msg->{to} = $attrs{'to'};
+        $msg->{from} = $attrs{router_from} if $attrs{router_from};
+        $msg->{from} = $attrs{from} unless $msg->{from};
+        $msg->{osrf_xid} = $attrs{'osrf_xid'};
+        $msg->{type} = $attrs{type};
+
+    } elsif($name eq 'body') {
+        $self->{xml_state} = IN_BODY;
+
+    } elsif($name eq 'thread') {
+        $self->{xml_state} = IN_THREAD;
+
+    } elsif($name eq 'stream:stream') {
+        $self->{stream_state} = CONNECT_RECV;
+
+    } elsif($name eq 'iq') {
+        if($attrs{type} and $attrs{type} eq 'result') {
+            $self->{stream_state} = CONNECTED;
+        }
+
+    } elsif($name eq 'status') {
+        $self->{xml_state } = IN_STATUS;
+
+    } elsif($name eq 'stream:error') {
+        $self->{stream_state} = DISCONNECTED;
+
+    } elsif($name eq 'error') {
+        $self->{message}->{err_type} = $attrs{'type'};
+        $self->{message}->{err_code} = $attrs{'code'};
+        $self->{stream_state} = DISCONNECTED;
+    }
+}
+
+sub characters {
+    my($parser, $chars) = @_;
+    my $self = $parser->{_parent_};
+    my $state = $self->{xml_state};
+
+    if($state == IN_BODY) {
+        $self->{message}->{body} .= $chars;
+
+    } elsif($state == IN_THREAD) {
+        $self->{message}->{thread} .= $chars;
+
+    } elsif($state == IN_STATUS) {
+        $self->{message}->{status} .= $chars;
+    }
+}
+
+sub end_element {
+    my($parser, $name) = @_;
+    my $self = $parser->{_parent_};
+    $self->{xml_state} = IN_NOTHING;
+
+    if($name eq 'message') {
+        $self->push_msg($self->{message});
+        $self->{message} = OpenSRF::Transport::SlimJabber::XMPPMessage->new;
+
+    } elsif($name eq 'stream:stream') {
+        $self->{stream_state} = DISCONNECTED;
+    }
+}
+
+sub flush_socket {
+       my $self = shift;
+       my $socket = $self->socket;
+    return 0 unless $socket and $socket->connected;
+
+    my $flags = fcntl($socket, F_GETFL, 0);
+    fcntl($socket, F_SETFL, $flags | O_NONBLOCK);
+
+    while( my $n = sysread( $socket, my $buf, 8192 ) ) {
+        $logger->debug("flush_socket dropped $n bytes of data");
+        $logger->error("flush_socket dropped data on disconnected socket: $buf")
+            unless($socket->connected);
+    }
+
+    fcntl($socket, F_SETFL, $flags);
+    return 0 unless $socket->connected;
+    return 1;
+}
+
+
+
+
+
+1;
+
+
+
+
+
diff --git a/src/perl/lib/OpenSRF/UnixServer.pm b/src/perl/lib/OpenSRF/UnixServer.pm
new file mode 100644 (file)
index 0000000..c4b48c8
--- /dev/null
@@ -0,0 +1,266 @@
+package OpenSRF::UnixServer;
+use strict; use warnings;
+use base qw/OpenSRF/;
+use OpenSRF::EX qw(:try);
+use OpenSRF::Utils::Logger qw(:level $logger);
+use OpenSRF::Transport::PeerHandle;
+use OpenSRF::Application;
+use OpenSRF::AppSession;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use OpenSRF::System;
+use OpenSRF::Utils::SettingsClient;
+use Time::HiRes qw(time);
+use OpenSRF::Utils::JSON;
+use vars qw/@ISA $app/;
+use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
+use Carp;
+use FreezeThaw qw/thaw/;
+
+use IO::Socket::INET;
+use IO::Socket::UNIX;
+
+sub DESTROY { confess "Dying $$"; }
+
+=head1 What am I
+
+All inbound messages are passed on to the UnixServer for processing.
+We take the data, close the Unix socket, and pass the data on to our abstract
+'process()' method.  
+
+Our purpose is to 'multiplex' a single TCP connection into multiple 'client' connections.
+So when you pass data down the Unix socket to us, we have been preforked and waiting
+to disperse new data among us.
+
+=cut
+
+sub app { return $app; }
+
+{
+
+       sub new {
+               my( $class, $app1 ) = @_;
+               if( ! $app1 ) {
+                       throw OpenSRF::EX::InvalidArg( "UnixServer requires an app name to run" );
+               }
+               $app = $app1;
+               my $self = bless( {}, $class );
+#              my $client = OpenSRF::Utils::SettingsClient->new();
+#              if( $client->config_value("server_type") !~ /fork/i || 
+#                              OpenSRF::Utils::Config->current->bootstrap->settings_config ) {
+#                      warn "Calling hooks for non-prefork\n";
+#                      $self->configure_hook();
+#                      $self->child_init_hook();
+#              }
+               return $self;
+       }
+
+}
+
+=head2 process_request()
+
+Takes the incoming data, closes the Unix socket and hands the data untouched 
+to the abstract process() method.  This method is implemented in our subclasses.
+
+=cut
+
+sub process_request {
+
+       my $self = shift;
+       my $data; my $d;
+       while( $d = <STDIN> ) { $data .= $d; }
+
+       my $orig = $0;
+       $0 = "$0*";
+
+       if( ! $data or ! defined( $data ) or $data eq "" ) {
+               close($self->{server}->{client}); 
+               $logger->debug("Unix child received empty data from socket", ERROR);
+               $0 = $orig;
+               return;
+       }
+
+
+       if( ! close( $self->{server}->{client} ) ) {
+               $logger->debug( "Error closing Unix socket: $!", ERROR );
+       }
+
+       my $app = $self->app();
+       $logger->transport( "UnixServer for $app received $data", INTERNAL );
+
+       # --------------------------------------------------------------
+       # Drop all data from the socket before coninuting to process
+       # --------------------------------------------------------------
+       my $ph = OpenSRF::Transport::PeerHandle->retrieve;
+       if(!$ph->flush_socket()) {
+               $logger->error("We received a request ".
+                       "and we are no longer connected to the jabber network. ".
+                       "We will go away and drop this request: $data");
+               exit;
+       }
+
+    ($data) = thaw($data);
+       my $app_session = OpenSRF::Transport->handler( $self->app(), $data );
+
+       if(!ref($app_session)) {
+               $logger->transport( "Did not receive AppSession from transport handler, returning...", WARN );
+               $0 = $orig;
+               return;
+       }
+
+       if($app_session->stateless and $app_session->state != $app_session->CONNECTED()){
+               $logger->debug("Exiting keepalive for stateless session / orig = $orig");
+               $app_session->kill_me;
+               $0 = $orig;
+               return;
+       }
+
+
+       my $client = OpenSRF::Utils::SettingsClient->new();
+       my $keepalive = $client->config_value("apps", $self->app(), "keepalive");
+
+       my $req_counter = 0;
+       while( $app_session and 
+                       $app_session->state and 
+                       $app_session->state != $app_session->DISCONNECTED() and
+                       $app_session->find( $app_session->session_id ) ) {
+               
+
+               my $before = time;
+               $logger->debug( "UnixServer calling queue_wait $keepalive", INTERNAL );
+               $app_session->queue_wait( $keepalive );
+               $logger->debug( "after queue wait $keepalive", INTERNAL );
+               my $after = time;
+
+               if( ($after - $before) >= $keepalive ) { 
+
+                       my $res = OpenSRF::DomainObject::oilsConnectStatus->new(
+                                                                       status => "Disconnected on timeout",
+                                                                       statusCode => STATUS_TIMEOUT);
+                       $app_session->status($res);
+                       $app_session->state( $app_session->DISCONNECTED() );
+                       last;
+               }
+       
+       }
+
+       my $x = 0;
+       while( $app_session && $app_session->queue_wait(0) ) {
+               $logger->debug( "Looping on zombies " . $x++ , DEBUG);
+       }
+
+       $logger->debug( "Timed out, disconnected, or authentication failed" );
+       $app_session->kill_me if ($app_session);
+
+       $0 = $orig;
+}
+
+
+sub serve {
+       my( $self ) = @_;
+
+       my $app = $self->app();
+       $logger->set_service($app);
+
+       $0 = "OpenSRF master [$app]";
+
+       my $client = OpenSRF::Utils::SettingsClient->new();
+    my @base = ('apps', $app, 'unix_config' );
+
+       my $min_servers = $client->config_value(@base, 'min_children');
+       my $max_servers = $client->config_value(@base, "max_children" );
+       my $min_spare = $client->config_value(@base, "min_spare_children" );
+       my $max_spare = $client->config_value(@base, "max_spare_children" );
+       my $max_requests = $client->config_value(@base, "max_requests" );
+    # fwiw, these file paths are (obviously) not portable
+       my $log_file = join("/", $client->config_value("dirs", "log"), $client->config_value(@base, "unix_log" ));
+       my $port = join("/", $client->config_value("dirs", "sock"), $client->config_value(@base, "unix_sock" ));
+       my $pid_file = join("/", $client->config_value("dirs", "pid"), $client->config_value(@base, "unix_pid" ));
+
+    $min_spare ||= $min_servers;
+    $max_spare ||= $max_servers;
+    $max_requests ||= 1000;
+
+    $logger->info("UnixServer: min=$min_servers, max=$max_servers, min_spare=$min_spare ".
+        "max_spare=$max_spare, max_req=$max_requests, log_file=$log_file, port=$port, pid_file=$pid_file");
+
+    $self->run(
+        min_servers => $min_servers,
+        max_servers => $max_servers,
+        min_spare_servers => $min_spare,
+        max_spare_servers => $max_spare,
+        max_requests => $max_requests,
+        log_file => $log_file,
+        port => $port,
+        proto => 'unix',
+        pid_file => $pid_file,
+    );
+
+}
+
+
+sub configure_hook {
+       my $self = shift;
+       my $app = $self->app;
+
+       # boot a client
+       OpenSRF::System->bootstrap_client( client_name => "system_client" );
+
+       $logger->debug( "Setting application implementation for $app", DEBUG );
+       my $client = OpenSRF::Utils::SettingsClient->new();
+       my $imp = $client->config_value("apps", $app, "implementation");
+       OpenSRF::Application::server_class($app);
+       OpenSRF::Application->application_implementation( $imp );
+       OpenSRF::Utils::JSON->register_class_hint( name => $imp, hint => $app, type => "hash" );
+       OpenSRF::Application->application_implementation->initialize()
+               if (OpenSRF::Application->application_implementation->can('initialize'));
+
+       if( $client->config_value("server_type") !~ /fork/i  ) {
+               $self->child_init_hook();
+       }
+
+       my $con = OpenSRF::Transport::PeerHandle->retrieve;
+       if($con) {
+               $con->disconnect;
+       }
+
+       return OpenSRF::Application->application_implementation;
+}
+
+sub child_init_hook { 
+
+       $0 =~ s/master/drone/g;
+
+       if ($ENV{OPENSRF_PROFILE}) {
+               my $file = $0;
+               $file =~ s/\W/_/go;
+               eval "use Devel::Profiler output_file => '/tmp/profiler_$file.out', buffer_size => 0;";
+               if ($@) {
+                       $logger->debug("Could not load Devel::Profiler: $@",ERROR);
+               } else {
+                       $0 .= ' [PROFILING]';
+                       $logger->debug("Running under Devel::Profiler", INFO);
+               }
+       }
+
+       my $self = shift;
+
+#      $logger->transport( 
+#                      "Creating PeerHandle from UnixServer child_init_hook", INTERNAL );
+       OpenSRF::Transport::PeerHandle->construct( $self->app() );
+       $logger->transport( "PeerHandle Created from UnixServer child_init_hook", INTERNAL );
+
+       OpenSRF::Application->application_implementation->child_init
+               if (OpenSRF::Application->application_implementation->can('child_init'));
+
+       return OpenSRF::Transport::PeerHandle->retrieve;
+}
+
+sub child_finish_hook {
+    $logger->debug("attempting to call child exit handler...");
+       OpenSRF::Application->application_implementation->child_exit
+               if (OpenSRF::Application->application_implementation->can('child_exit'));
+}
+
+
+1;
+
diff --git a/src/perl/lib/OpenSRF/Utils.pm b/src/perl/lib/OpenSRF/Utils.pm
new file mode 100644 (file)
index 0000000..46816cb
--- /dev/null
@@ -0,0 +1,464 @@
+package OpenSRF::Utils;
+
+=head1 NAME 
+
+OpenSRF::Utils
+
+=head1 DESCRIPTION 
+
+This is a container package for methods that are useful to derived modules.
+It has no constructor, and is generally not useful by itself... but this
+is where most of the generic methods live.
+
+=head1 METHODS 
+
+
+=cut
+
+use vars qw/@ISA $AUTOLOAD %EXPORT_TAGS @EXPORT_OK @EXPORT $VERSION/;
+push @ISA, 'Exporter';
+
+$VERSION = do { my @r=(q$Revision$=~/\d+/g); sprintf "%d."."%02d"x$#r,@r };
+
+use Time::Local;
+use Errno;
+use POSIX;
+use FileHandle;
+#use Cache::FileCache;
+#use Storable qw(dclone);
+use Digest::MD5 qw(md5 md5_hex md5_base64);
+use Exporter;
+use DateTime;
+use DateTime::Format::ISO8601;
+use DateTime::TimeZone;
+
+our $date_parser = DateTime::Format::ISO8601->new;
+
+# This turns errors into warnings, so daemons don't die.
+#$Storable::forgive_me = 1;
+
+%EXPORT_TAGS = (
+       common          => [qw(interval_to_seconds seconds_to_interval sendmail tree_filter)],
+       daemon          => [qw(safe_fork set_psname daemonize)],
+       datetime        => [qw(clense_ISO8601 gmtime_ISO8601 interval_to_seconds seconds_to_interval)],
+);
+
+Exporter::export_ok_tags('common','daemon','datetime');  # add aa, cc and dd to @EXPORT_OK
+
+sub AUTOLOAD {
+       my $self = shift;
+       my $type = ref($self) or return undef;
+
+       my $name = $AUTOLOAD;
+       $name =~ s/.*://;   # strip fully-qualified portion
+
+       if (defined($_[0])) {
+               return $self->{$name} = shift;
+       }
+       return $self->{$name};
+}
+
+
+sub _sub_builder {
+       my $self = shift;
+       my $class = ref($self) || $self;
+       my $part = shift;
+       unless ($class->can($part)) {
+               *{$class.'::'.$part} =
+                       sub {
+                               my $self = shift;
+                               my $new_val = shift;
+                               if ($new_val) {
+                                       $$self{$part} = $new_val;
+                               }
+                               return $$self{$part};
+               };
+       }
+}
+
+sub tree_filter {
+       my $tree = shift;
+       my $field = shift;
+       my $filter = shift;
+
+       my @things = $filter->($tree);
+       for my $v ( @{$tree->$field} ){
+               push @things, $filter->($v);
+               push @things, tree_filter($v, $field, $filter);
+       }
+       return @things
+}
+
+#sub standalone_ipc_cache {
+#      my $self = shift;
+#      my $class = ref($self) || $self;
+#      my $uniquifier = shift || return undef;
+#      my $expires = shift || 3600;
+
+#      return new Cache::FileCache ( { namespace => $class.'::'.$uniquifier, default_expires_in => $expires } );
+#}
+
+sub sendmail {
+       my $self = shift;
+        my $message = shift || $self;
+
+        open SM, '|/usr/sbin/sendmail -U -t' or return 0;
+        print SM $message;
+        close SM or return 0;
+        return 1;
+}
+
+sub __strip_comments {
+       my $self = shift;
+       my $config_file = shift;
+       my ($line, @done);
+       while (<$config_file>) {
+               s/^\s*(.*)\s*$/$1/o if (lc($$self{keep_space}) ne 'true');
+               /^(.*)$/o;
+               $line .= $1;
+               # keep new lines if keep_space is true
+               if ($line =~ /^$/o && (lc($$self{keep_space}) ne 'true')) {
+                       $line = '';
+                       next;
+               }
+               if (/^([^<]+)\s*<<\s*(\w+)\s*$/o) {
+                       $line = "$1 = ";
+                       my $breaker = $2;
+                       while (<$config_file>) {
+                               chomp;
+                               last if (/^$breaker/);
+                               $line .= $_;
+                       }
+               }
+
+               if ($line =~ /^#/ && $line !~ /^#\s*include\s+/o) {
+                       $line = '';
+                       next;
+               }
+               if ($line =~ /\\$/o) {
+                       chomp $line;
+                       $line =~ s/^\s*(.*)\s*\\$/$1/o;
+                       next;
+               }
+               push @done, $line;
+               $line = '';
+       }
+       return @done;
+}
+
+
+=head2 $thing->encrypt(@stuff)
+
+Returns a one way hash (MD5) of the values appended together.
+
+=cut
+
+sub encrypt {
+       my $self = shift;
+       return md5_hex(join('',@_));
+}
+
+=head2 $utils_obj->es_time('field') OR noo_es_time($timestamp)
+
+Returns the epoch-second style timestamp for the value stored in
+$utils_obj->{field}.  Returns B<0> for an empty or invalid date stamp, and
+assumes a PostgreSQL style datestamp to be supplied.
+
+=cut
+
+sub es_time {
+       my $self = shift;
+       my $part = shift;
+       my $es_part = $part.'_ES';
+       return $$self{$es_part} if (exists($$self{$es_part}) && defined($$self{$es_part}) && $$self{$es_part});
+       if (!$$self{$part} or $$self{$part} !~ /\d+/) {
+               return 0;
+
+       }
+       my @tm = reverse($$self{$part} =~ /([\d\.]+)/og);
+       if ($tm[5] > 0) {
+               $tm[5] -= 1;
+       }
+
+        return $$self{$es_part} = noo_es_time($$self{$part});
+}
+
+=head2 noo_es_time($timestamp) (non-OO es_time)
+
+Returns the epoch-second style timestamp for the B<$timestamp> passed
+in.  Returns B<0> for an empty or invalid date stamp, and
+assumes a PostgreSQL style datestamp to be supplied.
+
+=cut
+
+sub noo_es_time {
+        my $timestamp = shift;
+
+        my @tm = reverse($timestamp =~ /([\d\.]+)/og);
+        if ($tm[5] > 0) {
+                $tm[5] -= 1;
+        }
+        return timelocal(int($tm[1]), int($tm[2]), int($tm[3]), int($tm[4]) || 1, int($tm[5]), int($tm[6]) || 2002 );
+}
+
+
+=head2 $thing->interval_to_seconds('interval') OR interval_to_seconds('interval')
+
+=head2 $thing->seconds_to_interval($seconds) OR seconds_to_interval($seconds)
+
+Returns the number of seconds for any interval passed, or the interval for the seconds.
+This is the generic version of B<interval> listed below.
+
+The interval must match the regex I</\s*\+?\s*(\d+)\s*(\w{1})\w*\s*/g>, for example
+B<2 weeks, 3 d and 1hour + 17 Months> or
+B<1 year, 5 Months, 2 weeks, 3 days and 1 hour of seconds> meaning 46148400 seconds.
+
+       my $expire_time = time() + $thing->interval_to_seconds('17h 9m');
+
+The time size indicator may be one of
+
+=over 2
+
+=item s[econd[s]]
+
+for seconds
+
+=item m[inute[s]]
+
+for minutes
+
+=item h[our[s]]
+
+for hours
+
+=item d[ay[s]]
+
+for days
+
+=item w[eek[s]]
+
+for weeks
+
+=item M[onth[s]]
+
+for months (really (365 * 1d)/12 ... that may get smarter, though)
+
+=item y[ear[s]]
+
+for years (this is 365 * 1d)
+
+=back
+
+=cut
+sub interval_to_seconds {
+       my $self = shift;
+        my $interval = shift || $self;
+
+        $interval =~ s/and/,/g;
+        $interval =~ s/,/ /g;
+
+        my $amount = 0;
+        while ($interval =~ /\s*\+?\s*(\d+)\s*(\w+)\s*/g) {
+               my ($count, $type) = ($1, $2);
+                $amount += $count if ($type eq 's');
+                $amount += 60 * $count if ($type =~ /^m(?!o)/oi);
+                $amount += 60 * 60 * $count if ($type =~ /^h/);
+                $amount += 60 * 60 * 24 * $count if ($type =~ /^d/oi);
+                $amount += 60 * 60 * 24 * 7 * $count if ($2 =~ /^w/oi);
+                $amount += ((60 * 60 * 24 * 365)/12) * $count if ($type =~ /^mo/io);
+                $amount += 60 * 60 * 24 * 365 * $count if ($type =~ /^y/oi);
+        }
+        return $amount;
+}
+
+sub seconds_to_interval {
+       my $self = shift;
+        my $interval = shift || $self;
+
+        my $limit = shift || 's';
+        $limit =~ s/^(.)/$1/o;
+
+        my ($y,$ym,$M,$Mm,$w,$wm,$d,$dm,$h,$hm,$m,$mm,$s,$string);
+        my ($year, $month, $week, $day, $hour, $minute, $second) =
+                ('year','Month','week','day', 'hour', 'minute', 'second');
+
+        if ($y = int($interval / (60 * 60 * 24 * 365))) {
+                $string = "$y $year". ($y > 1 ? 's' : '');
+                $ym = $interval % (60 * 60 * 24 * 365);
+        } else {
+                $ym = $interval;
+        }
+        return $string if ($limit eq 'y');
+
+        if ($M = int($ym / ((60 * 60 * 24 * 365)/12))) {
+                $string .= ($string ? ', ':'')."$M $month". ($M > 1 ? 's' : '');
+                $Mm = $ym % ((60 * 60 * 24 * 365)/12);
+        } else {
+                $Mm = $ym;
+        }
+        return $string if ($limit eq 'M');
+
+        if ($w = int($Mm / 604800)) {
+                $string .= ($string ? ', ':'')."$w $week". ($w > 1 ? 's' : '');
+                $wm = $Mm % 604800;
+        } else {
+                $wm = $Mm;
+        }
+        return $string if ($limit eq 'w');
+
+        if ($d = int($wm / 86400)) {
+                $string .= ($string ? ', ':'')."$d $day". ($d > 1 ? 's' : '');
+                $dm = $wm % 86400;
+        } else {
+                $dm = $wm;
+        }
+        return $string if ($limit eq 'd');
+
+        if ($h = int($dm / 3600)) {
+                $string .= ($string ? ', ' : '')."$h $hour". ($h > 1 ? 's' : '');
+                $hm = $dm % 3600;
+        } else {
+                $hm = $dm;
+        }
+        return $string if ($limit eq 'h');
+
+        if ($m = int($hm / 60)) {
+                $string .= ($string ? ', ':'')."$m $minute". ($m > 1 ? 's' : '');
+                $mm = $hm % 60;
+        } else {
+                $mm = $hm;
+        }
+        return $string if ($limit eq 'm');
+
+        if ($s = int($mm)) {
+                $string .= ($string ? ', ':'')."$s $second". ($s > 1 ? 's' : '');
+        } else {
+                $string = "0s" unless ($string);
+        }
+        return $string;
+}
+
+sub full {
+       my $self = shift;
+       $$self{empty} = 0;
+}
+
+=head2 $utils_obj->set_psname('string') OR set_psname('string')
+
+Sets the name of this process in a B<ps> listing to B<string>.
+
+
+=cut
+
+sub set_psname {
+       my $self = shift;
+       my $PS_NAME = shift || $self;
+       $0 = $PS_NAME if ($PS_NAME);
+}
+
+sub gmtime_ISO8601 {
+       my $self = shift;
+       my @date = gmtime;
+
+       my $y = $date[5] + 1900;
+       my $M = $date[4] + 1;
+       my $d = $date[3];
+       my $h = $date[2];
+       my $m = $date[1];
+       my $s = $date[0];
+
+       return sprintf('%d-%0.2d-%0.2dT%0.2d:%0.2d:%0.2d+00:00', $y, $M, $d, $h, $m, $s);
+}
+
+sub clense_ISO8601 {
+       my $self = shift;
+       my $date = shift || $self;
+       if ($date =~ /^\s*(\d{4})-?(\d{2})-?(\d{2})/o) {
+               my $new_date = "$1-$2-$3";
+
+               if ($date =~/(\d{2}):(\d{2}):(\d{2})/o) {
+                       $new_date .= "T$1:$2:$3";
+
+                       my $z;
+                       if ($date =~ /([-+]{1})([0-9]{1,2})(?::?([0-9]{1,2}))*\s*$/o) {
+                               $z = sprintf('%s%0.2d%0.2d',$1,$2,$3)
+                       } else {
+                               $z =  DateTime::TimeZone::offset_as_string(
+                                       DateTime::TimeZone
+                                               ->new( name => 'local' )
+                                               ->offset_for_datetime(
+                                                       $date_parser->parse_datetime($new_date)
+                                               )
+                               );
+                       }
+
+                       if (length($z) > 3 && index($z, ':') == -1) {
+                               substr($z,3,0) = ':';
+                               substr($z,6,0) = ':' if (length($z) > 6);
+                       }
+               
+                       $new_date .= $z;
+               } else {
+                       $new_date .= "T00:00:00";
+               }
+
+               return $new_date;
+       }
+       return $date;
+}
+
+=head2 $utils_obj->daemonize('ps_name') OR daemonize('ps_name')
+
+Turns the current process into a daemon.  B<ps_name> is optional, and is used
+as the argument to I<< set_psname() >> if passed.
+
+
+=cut
+
+sub daemonize {
+       my $self = shift;
+       my $PS_NAME = shift || $self;
+       my $pid;
+       if ($pid = safe_fork($self)) {
+               exit 0;
+       } elsif (defined($pid)) {
+               set_psname($PS_NAME);
+               chdir '/';
+               setsid;
+               return $$;
+       }
+}
+
+=head2 $utils_obj->safe_fork('ps_name') OR safe_fork('ps_name');
+
+Forks the current process in a retry loop.  B<ps_name> is optional, and is used
+as the argument to I<< set_psname() >> if passed.
+
+
+=cut
+
+sub safe_fork {
+       my $self = shift;
+       my $pid;
+
+FORK:
+       {
+               if (defined($pid = fork())) {
+                       srand(time ^ ($$ + ($$ << 15))) unless ($pid);
+                       return $pid;
+               } elsif ($! == EAGAIN) {
+                       $self->error("Can't fork()!  $!, taking 5 and trying again.") if (ref $self);
+                       sleep 5;
+                       redo FORK;
+               } else {
+                       $self->error("Can't fork()! $!") if ($! && ref($self));
+                       exit $!;
+               }
+       }
+}
+
+#------------------------------------------------------------------------------------------------------------------------------------
+
+
+1;
diff --git a/src/perl/lib/OpenSRF/Utils/Cache.pm b/src/perl/lib/OpenSRF/Utils/Cache.pm
new file mode 100644 (file)
index 0000000..20f76df
--- /dev/null
@@ -0,0 +1,257 @@
+package OpenSRF::Utils::Cache;
+use strict; use warnings;
+use base qw/OpenSRF/;
+use Cache::Memcached;
+use OpenSRF::Utils::Logger qw/:level/;
+use OpenSRF::Utils::Config;
+use OpenSRF::Utils::SettingsClient;
+use OpenSRF::EX qw(:try);
+use OpenSRF::Utils::JSON;
+
+my $log = 'OpenSRF::Utils::Logger';
+
+=head1 NAME
+
+OpenSRF::Utils::Cache
+
+=head1 SYNOPSIS
+
+This class just subclasses Cache::Memcached.
+see Cache::Memcached for more options.
+
+The value passed to the call to current is the cache type
+you wish to access.  The below example sets/gets data
+from the 'user' cache.
+
+my $cache = OpenSRF::Utils::Cache->current("user");
+$cache->set( "key1", "value1" [, $expire_secs ] );
+my $val = $cache->get( "key1" );
+
+
+=cut
+
+sub DESTROY {}
+
+my %caches;
+
+# ------------------------------------------------------
+# Persist methods and method names
+# ------------------------------------------------------
+my $persist_add_slot; 
+my $persist_push_stack;
+my $persist_peek_stack;
+my $persist_destroy_slot;
+my $persist_slot_get_expire;
+my $persist_slot_find;
+
+my $max_persist_time;
+my $persist_add_slot_name       = "opensrf.persist.slot.create_expirable";
+my $persist_push_stack_name     = "opensrf.persist.stack.push";
+my $persist_peek_stack_name     = "opensrf.persist.stack.peek";
+my $persist_destroy_slot_name   = "opensrf.persist.slot.destroy";
+my $persist_slot_get_expire_name = "opensrf.persist.slot.get_expire";
+my $persist_slot_find_name      = "opensrf.persist.slot.find";;
+
+# ------------------------------------------------------
+
+=head1 METHODS
+
+=head2 current
+
+Return a named cache if it exists
+
+=cut
+
+sub current {
+       my ( $class, $c_type )  = @_;
+       return undef unless $c_type;
+       return $caches{$c_type} if exists $caches{$c_type};
+       return $caches{$c_type} = $class->new( $c_type );
+}
+
+
+=head2 new
+
+Create a new named memcache object.
+
+=cut
+
+sub new {
+
+       my( $class, $cache_type, $persist ) = @_;
+       $cache_type ||= 'global';
+       $class = ref( $class ) || $class;
+
+       return $caches{$cache_type} if (defined $caches{$cache_type});
+
+       my $conf = OpenSRF::Utils::SettingsClient->new;
+       my $servers = $conf->config_value( cache => $cache_type => servers => 'server' );
+       $max_persist_time = $conf->config_value( cache => $cache_type => 'max_cache_time' );
+
+       $servers = [ $servers ] if(!ref($servers))
+
+       my $self = {};
+       $self->{persist} = $persist || 0;
+       $self->{memcache} = Cache::Memcached->new( { servers => $servers } ); 
+       if(!$self->{memcache}) {
+               throw OpenSRF::EX::PANIC ("Unable to create a new memcache object for $cache_type");
+       }
+
+       bless($self, $class);
+       $caches{$cache_type} = $self;
+       return $self;
+}
+
+
+=head2 put_cache
+
+=cut
+
+sub put_cache {
+       my($self, $key, $value, $expiretime ) = @_;
+       return undef unless( defined $key and defined $value );
+
+       $value = OpenSRF::Utils::JSON->perl2JSON($value);
+
+       if($self->{persist}){ _load_methods(); }
+
+       $expiretime ||= $max_persist_time;
+
+       unless( $self->{memcache}->set( $key, $value, $expiretime ) ) {
+               $log->error("Unable to store $key => [".length($value)." bytes]  in memcached server" );
+               return undef;
+       }
+
+       $log->debug("Stored $key => $value in memcached server", INTERNAL);
+
+       if($self->{"persist"}) {
+
+               my ($slot) = $persist_add_slot->run("_CACHEVAL_$key", $expiretime . "s");
+
+               if(!$slot) {
+                       # slot may already exist
+                       ($slot) = $persist_slot_find->run("_CACHEVAL_$key");
+                       if(!defined($slot)) {
+                               throw OpenSRF::EX::ERROR ("Unable to create cache slot $key in persist server" );
+                       } else {
+                               #XXX destroy the slot and rebuild it to prevent DOS
+                       }
+               }
+
+               ($slot) = $persist_push_stack->run("_CACHEVAL_$key", $value);
+
+               if(!$slot) {
+                       throw OpenSRF::EX::ERROR ("Unable to push data onto stack in persist slot _CACHEVAL_$key" );
+               }
+       }
+
+       return $key;
+}
+
+
+=head2 delete_cache
+
+=cut
+
+sub delete_cache {
+       my( $self, $key ) = @_;
+       if(!$key) { return undef; }
+       if($self->{persist}){ _load_methods(); }
+       $self->{memcache}->delete($key);
+       if( $self->{persist} ) {
+               $persist_destroy_slot->run("_CACHEVAL_$key");
+       }
+       return $key; 
+}
+
+
+=head2 get_cache
+
+=cut
+
+sub get_cache {
+       my($self, $key ) = @_;
+
+       my $val = $self->{memcache}->get( $key );
+       return OpenSRF::Utils::JSON->JSON2perl($val) if defined($val);
+
+       if($self->{persist}){ _load_methods(); }
+
+       # if not in memcache but we are persisting, the put it into memcache
+       if( $self->{"persist"} ) {
+               $val = $persist_peek_stack->( "_CACHEVAL_$key" );
+               if(defined($val)) {
+                       my ($expire) = $persist_slot_get_expire->run("_CACHEVAL_$key");
+                       if($expire)     {
+                               $self->{memcache}->set( $key, $val, $expire);
+                       } else {
+                               $self->{memcache}->set( $key, $val, $max_persist_time);
+                       }
+                       return OpenSRF::Utils::JSON->JSON2perl($val);
+               }
+       }
+       return undef;
+}
+
+
+=head2 _load_methods
+
+=cut
+
+sub _load_methods {
+
+       if(!$persist_add_slot) {
+               $persist_add_slot = 
+                       OpenSRF::Application->method_lookup($persist_add_slot_name);
+               if(!ref($persist_add_slot)) {
+                       throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_add_slot_name");
+               }
+       }
+
+       if(!$persist_push_stack) {
+               $persist_push_stack = 
+                       OpenSRF::Application->method_lookup($persist_push_stack_name);
+               if(!ref($persist_push_stack)) {
+                       throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_push_stack_name");
+               }
+       }
+
+       if(!$persist_peek_stack) {
+               $persist_peek_stack = 
+                       OpenSRF::Application->method_lookup($persist_peek_stack_name);
+               if(!ref($persist_peek_stack)) {
+                       throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_peek_stack_name");
+               }
+       }
+
+       if(!$persist_destroy_slot) {
+               $persist_destroy_slot = 
+                       OpenSRF::Application->method_lookup($persist_destroy_slot_name);
+               if(!ref($persist_destroy_slot)) {
+                       throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_destroy_slot_name");
+               }
+       }
+       if(!$persist_slot_get_expire) {
+               $persist_slot_get_expire = 
+                       OpenSRF::Application->method_lookup($persist_slot_get_expire_name);
+               if(!ref($persist_slot_get_expire)) {
+                       throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_slot_get_expire_name");
+               }
+       }
+       if(!$persist_slot_find) {
+               $persist_slot_find = 
+                       OpenSRF::Application->method_lookup($persist_slot_find_name);
+               if(!ref($persist_slot_find)) {
+                       throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_slot_find_name");
+               }
+       }
+}
+
+
+
+
+
+
+
+1;
+
diff --git a/src/perl/lib/OpenSRF/Utils/Config.pm b/src/perl/lib/OpenSRF/Utils/Config.pm
new file mode 100755 (executable)
index 0000000..ca400f7
--- /dev/null
@@ -0,0 +1,411 @@
+package OpenSRF::Utils::Config::Section;
+
+no strict 'refs';
+
+use vars qw/@ISA $AUTOLOAD $VERSION/;
+push @ISA, qw/OpenSRF::Utils/;
+
+use OpenSRF::Utils (':common');
+use Net::Domain qw/hostfqdn/;
+
+$VERSION = do { my @r=(q$Revision$=~/\d+/g); sprintf "%d."."%02d"x$#r,@r };
+
+my %SECTIONCACHE;
+my %SUBSECTION_FIXUP;
+
+#use overload '""' => \&OpenSRF::Utils::Config::dump_ini;
+
+sub SECTION {
+       my $sec = shift;
+       return $sec->__id(@_);
+}
+
+sub new {
+       my $self = shift;
+       my $class = ref($self) || $self;
+
+       $self = bless {}, $class;
+
+       $self->_sub_builder('__id');
+       # Hard-code this to match old bootstrap.conf section name
+       $self->__id('bootstrap');
+
+       my $bootstrap = shift;
+
+       foreach my $key (sort keys %$bootstrap) {
+               $self->_sub_builder($key);
+               $self->$key($bootstrap->{$key});
+       }
+
+       return $self;
+}
+
+package OpenSRF::Utils::Config;
+
+use vars qw/@ISA $AUTOLOAD $VERSION $OpenSRF::Utils::ConfigCache/;
+push @ISA, qw/OpenSRF::Utils/;
+
+use FileHandle;
+use XML::LibXML;
+use OpenSRF::Utils (':common');  
+use OpenSRF::Utils::Logger;
+use Net::Domain qw/hostfqdn/;
+
+#use overload '""' => \&OpenSRF::Utils::Config::dump_ini;
+
+sub import {
+       my $class = shift;
+       my $config_file = shift;
+
+       return unless $config_file;
+
+       $class->load( config_file => $config_file);
+}
+
+sub dump_ini {
+       no warnings;
+        my $self = shift;
+        my $string;
+       my $included = 0;
+       if ($self->isa('OpenSRF::Utils::Config')) {
+               if (UNIVERSAL::isa(scalar(caller()), 'OpenSRF::Utils::Config' )) {
+                       $included = 1;
+               } else {
+                       $string = "# Main File:  " . $self->FILE . "\n\n" . $string;
+               }
+       }
+        for my $section ( ('__id', grep { $_ ne '__id' } sort keys %$self) ) {
+               next if ($section eq 'env' && $self->isa('OpenSRF::Utils::Config'));
+                if ($section eq '__id') {
+                       $string .= '['.$self->SECTION."]\n" if ($self->isa('OpenSRF::Utils::Config::Section'));
+               } elsif (ref($self->$section)) {
+                        if (ref($self->$section) =~ /ARRAY/o) {
+                                $string .= "list:$section = ". join(', ', @{$self->$section}) . "\n";
+                       } elsif (UNIVERSAL::isa($self->$section,'OpenSRF::Utils::Config::Section')) {
+                               if ($self->isa('OpenSRF::Utils::Config::Section')) {
+                                       $string .= "subsection:$section = " . $self->$section->SECTION . "\n";
+                                       next;
+                               } else {
+                                       next if ($self->$section->{__sub} && !$included);
+                                       $string .= $self->$section . "\n";
+                               }
+                        } elsif (UNIVERSAL::isa($self->$section,'OpenSRF::Utils::Config')) {
+                               $string .= $self->$section . "\n";
+                       }
+               } else {
+                       next if $section eq '__sub';
+                               $string .= "$section = " . $self->$section . "\n";
+               }
+        }
+       if ($included) {
+               $string =~ s/^/## /gm;
+               $string = "# Subfile:  " . $self->FILE . "\n#" . '-'x79 . "\n".'#include "'.$self->FILE."\"\n". $string;
+       }
+
+        return $string;
+}
+
+=head1 NAME
+OpenSRF::Utils::Config
+
+=head1 SYNOPSIS
+
+  use OpenSRF::Utils::Config;
+
+  my $config_obj = OpenSRF::Utils::Config->load( config_file   => '/config/file.cnf' );
+
+  my $attrs_href = $config_obj->bootstrap();
+
+  $config_obj->bootstrap->loglevel(0);
+
+  open FH, '>'.$config_obj->FILE() . '.new';
+  print FH $config_obj;
+  close FH;
+
+=head1 DESCRIPTION
+
+This module is mainly used by other OpenSRF modules to load an OpenSRF
+configuration file.  OpenSRF configuration files are XML files that
+contain a C<< <config> >> root element and an C<< <opensrf> >> child
+element (in XPath notation, C</config/opensrf/>). Each child element
+is converted into a hash key=>value pair. Elements that contain other
+XML elements are pushed into arrays and added as an array reference to
+the hash. Scalar values have whitespace trimmed from the left and
+right sides.
+
+Child elements of C<< <config> >> other than C<< <opensrf> >> are
+currently ignored by this module.
+
+=head1 EXAMPLE
+
+Given an OpenSRF configuration file named F<opensrf_core.xml> with the
+following content:
+
+  <?xml version='1.0'?>
+  <config>
+    <opensrf>
+      <router_name>router</router_name>
+
+      <routers> 
+       <router>localhost</router>
+       <router>otherhost</router>
+      </routers>
+
+      <logfile>/var/log/osrfsys.log</logfile>
+    </opensrf>
+  </config>
+
+... calling C<< OpenSRF::Utils::Config->load(config_file =>
+'opensrf_core.xml') >> will create a hash with the following
+structure:
+
+  {
+    router_name => 'router',
+    routers => ['localhost', 'otherhost'],
+    logfile => '/var/log/osrfsys.log'
+  }
+
+You can retrieve any of these values by name from the bootstrap
+section of C<$config_obj>; for example:
+
+  $config_obj->bootstrap->router_name
+
+=head1 NOTES
+
+For compatibility with a previous version of OpenSRF configuration
+files, the F</config/opensrf/> section has a hardcoded name of
+B<bootstrap>. However, future iterations of this module may extend the
+ability of the module to parse the entire OpenSRF configuration file
+and provide sections named after the sibling elements of
+C</config/opensrf>.
+
+Hashrefs of sections can be returned by calling a method of the object
+of the same name as the section.  They can be set by passing a hashref
+back to the same method.  Sections will B<NOT> be autovivicated,
+though.
+
+
+=head1 METHODS
+
+
+=cut
+
+
+$VERSION = do { my @r=(q$Revision$=~/\d+/g); sprintf "%d."."%02d"x$#r,@r };
+
+
+=head2 OpenSRF::Utils::Config->load( config_file => '/some/config/file.cnf' )
+
+Returns a OpenSRF::Utils::Config object representing the config file
+that was loaded.  The most recently loaded config file (hopefully the
+only one per app) is stored at $OpenSRF::Utils::ConfigCache. Use
+OpenSRF::Utils::Config::current() to get at it.
+
+=cut
+
+sub load {
+       my $pkg = shift;
+       $pkg = ref($pkg) || $pkg;
+
+       my %args = @_;
+
+       (my $new_pkg = $args{config_file}) =~ s/\W+/_/g;
+       $new_pkg .= "::$pkg";
+       $new_section_pkg .= "${new_pkg}::Section";
+
+       {       eval <<"                PERL";
+
+                       package $new_pkg;
+                       use base $pkg;
+                       sub section_pkg { return '$new_section_pkg'; }
+
+                       package $new_section_pkg;
+                       use base "${pkg}::Section";
+       
+               PERL
+       }
+
+       return $new_pkg->_load( %args );
+}
+
+sub _load {
+       my $pkg = shift;
+       $pkg = ref($pkg) || $pkg;
+       my $self = {@_};
+       bless $self, $pkg;
+
+       no warnings;
+       if ((exists $$self{config_file} and OpenSRF::Utils::Config->current) and (OpenSRF::Utils::Config->current->FILE eq $$self{config_file}) and (!$self->{force})) {
+               delete $$self{force};
+               return OpenSRF::Utils::Config->current();
+       }
+
+       $self->_sub_builder('__id');
+       $self->FILE($$self{config_file});
+       delete $$self{config_file};
+       return undef unless ($self->FILE);
+
+       $self->load_config();
+       $self->load_env();
+       $self->mangle_dirs();
+       $self->mangle_logs();
+
+       $OpenSRF::Utils::ConfigCache = $self unless $self->nocache;
+       delete $$self{nocache};
+       delete $$self{force};
+       return $self;
+}
+
+sub sections {
+       my $self = shift;
+       my %filters = @_;
+
+       my @parts = (grep { UNIVERSAL::isa($_,'OpenSRF::Utils::Config::Section') } values %$self);
+       if (keys %filters) {
+               my $must_match = scalar(keys %filters);
+               my @ok_parts;
+               foreach my $part (@parts) {
+                       my $part_count = 0;
+                       for my $fkey (keys %filters) {
+                               $part_count++ if ($part->$key eq $filters{$key});
+                       }
+                       push @ok_parts, $part if ($part_count == $must_match);
+               }
+               return @ok_parts;
+       }
+       return @parts;
+}
+
+sub current {
+       return $OpenSRF::Utils::ConfigCache;
+}
+
+sub FILE {
+       return shift()->__id(@_);
+}
+
+sub load_env {
+       my $self = shift;
+       my $host = $ENV{'OSRF_HOSTNAME'} || hostfqdn();
+       chomp $host;
+       $$self{env} = $self->section_pkg->new;
+       $$self{env}{hostname} = $host;
+}
+
+sub mangle_logs {
+       my $self = shift;
+       return unless ($self->logs && $self->dirs && $self->dirs->log_dir);
+       for my $i ( keys %{$self->logs} ) {
+               next if ($self->logs->$i =~ /^\//);
+               $self->logs->$i($self->dirs->log_dir."/".$self->logs->$i);
+       }
+}
+
+sub mangle_dirs {
+       my $self = shift;
+       return unless ($self->dirs && $self->dirs->base_dir);
+       for my $i ( keys %{$self->dirs} ) {
+               if ( $i ne 'base_dir' ) {
+                       next if ($self->dirs->$i =~ /^\//);
+                       my $dir_tmp = $self->dirs->base_dir."/".$self->dirs->$i;
+                       $dir_tmp =~ s#//#/#go;
+                       $dir_tmp =~ s#/$##go;
+                       $self->dirs->$i($dir_tmp);
+               }
+       }
+}
+
+sub load_config {
+       my $self = shift;
+       my $parser = XML::LibXML->new();
+
+       # Hash of config values
+       my %bootstrap;
+       
+       # Return an XML::LibXML::Document object
+       my $config = $parser->parse_file($self->FILE);
+
+       unless ($config) {
+               OpenSRF::Utils::Logger->error("Could not open ".$self->FILE.": $!\n");
+               die "Could not open ".$self->FILE.": $!\n";
+       }
+
+       # Return an XML::LibXML::NodeList object matching all child elements
+       # of <config><opensrf>...
+       my $osrf_cfg = $config->findnodes('/config/opensrf/child::*');
+
+       # Iterate through the nodes to pull out key=>value pairs of config settings
+       foreach my $node ($osrf_cfg->get_nodelist()) {
+               my $child_state = 0;
+
+               # This will be overwritten if it's a scalar setting
+               $bootstrap{$node->nodeName()} = [];
+
+               foreach my $child_node ($node->childNodes) {
+                       # from libxml/tree.h: nodeType 1 = ELEMENT_NODE
+                       next if $child_node->nodeType() != 1;
+
+                       # If the child node is an element, this element may
+                       # have multiple values; therefore, push it into an array
+            my $content = OpenSRF::Utils::Config::extract_child($child_node);
+                       push(@{$bootstrap{$node->nodeName()}}, $content) if $content;
+                       $child_state = 1;
+               }
+               if (!$child_state) {
+                       $bootstrap{$node->nodeName()} = OpenSRF::Utils::Config::extract_text($node->textContent);
+               }
+       }
+
+       my $section = $self->section_pkg->new(\%bootstrap);
+       my $sub_name = $section->SECTION;
+       $self->_sub_builder($sub_name);
+       $self->$sub_name($section);
+
+}
+sub extract_child {
+    my $node = shift;
+    use OpenSRF::Utils::SettingsParser;
+    return OpenSRF::Utils::SettingsParser::XML2perl($node);
+}
+
+sub extract_text {
+       my $self = shift;
+       $self =~ s/^\s*([.*?])\s*$//m;
+       return $self;
+}
+
+#------------------------------------------------------------------------------------------------------------------------------------
+
+=head1 SEE ALSO
+
+       OpenSRF::Utils
+
+=head1 LIMITATIONS
+
+Elements containing heterogeneous child elements are treated as though they have the same element name;
+for example:
+  <routers>
+    <router>localhost</router>
+    <furniture>chair</furniture>
+  </routers>
+
+... will simply generate a key=>value pair of C<< routers => ['localhost', 'chair'] >>.
+
+=head1 BUGS
+
+No known bugs, but report any to open-ils-dev@list.georgialibraries.org or mrylander@gmail.com.
+
+=head1 COPYRIGHT AND LICENSING
+
+Copyright (C) 2000-2007, Mike Rylander
+Copyright (C) 2007, Laurentian University, Dan Scott <dscott@laurentian.ca>
+
+The OpenSRF::Utils::Config module is free software. You may distribute under the terms
+of the GNU General Public License version 2 or greater.
+
+=cut
+
+
+1;
diff --git a/src/perl/lib/OpenSRF/Utils/JSON.pm b/src/perl/lib/OpenSRF/Utils/JSON.pm
new file mode 100644 (file)
index 0000000..bfefb86
--- /dev/null
@@ -0,0 +1,128 @@
+package OpenSRF::Utils::JSON;
+use JSON::XS;
+use vars qw/%_class_map/;
+
+my $parser = JSON::XS->new;
+$parser->ascii(1); # output \u escaped strings
+$parser->allow_nonref(1);
+
+sub true {
+    return $parser->true();
+}
+
+sub false {
+    return $parser->false();
+}
+
+sub register_class_hint {
+       my $class = shift;
+       my %args = @_;
+       $_class_map{hints}{$args{hint}} = \%args;
+       $_class_map{classes}{$args{name}} = \%args;
+}
+
+sub lookup_class {
+       my $self = shift;
+       my $hint = shift;
+       return $_class_map{hints}{$hint}{name}
+}
+
+sub lookup_hint {
+       my $self = shift;
+       my $class = shift;
+       return $_class_map{classes}{$class}{hint}
+}
+
+sub _json_hint_to_class {
+       my $type = shift;
+       my $hint = shift;
+
+       return $_class_map{hints}{$hint}{name} if (exists $_class_map{hints}{$hint});
+       
+       $type = 'hash' if ($type eq '}');
+       $type = 'array' if ($type eq ']');
+
+       OpenSRF::Utils::JSON->register_class_hint(name => $hint, hint => $hint, type => $type);
+
+       return $hint;
+}
+
+
+my $JSON_CLASS_KEY = '__c';
+my $JSON_PAYLOAD_KEY = '__p';
+
+sub JSON2perl {
+       my( $class, $string ) = @_;
+       my $perl = $class->rawJSON2perl($string);
+       return $class->JSONObject2Perl($perl);
+}
+
+sub perl2JSON {
+       my( $class, $obj ) = @_;
+       my $json = $class->perl2JSONObject($obj);
+       return $class->rawPerl2JSON($json);
+}
+
+sub JSONObject2Perl {
+       my $class = shift;
+       my $obj = shift;
+       my $ref = ref($obj);
+       if( $ref eq 'HASH' ) {
+               if( defined($obj->{$JSON_CLASS_KEY})) {
+                       my $cls = $obj->{$JSON_CLASS_KEY};
+            $cls =~ s/^\s+//o;
+            $cls =~ s/\s+$//o;
+                       if( $obj = $class->JSONObject2Perl($obj->{$JSON_PAYLOAD_KEY}) ) {
+                               $cls = $class->lookup_class($cls) || $cls;
+                               return bless(\$obj, $cls) unless ref($obj); 
+                               return bless($obj, $cls);
+                       }
+                       return undef;
+               }
+               $obj->{$_} = $class->JSONObject2Perl($obj->{$_}) for (keys %$obj);
+       } elsif( $ref eq 'ARRAY' ) {
+               $obj->[$_] = $class->JSONObject2Perl($obj->[$_]) for(0..scalar(@$obj) - 1);
+       }
+       return $obj;
+}
+
+sub perl2JSONObject {
+       my $class = shift;
+       my $obj = shift;
+       my $ref = ref($obj);
+
+       return $obj unless $ref;
+
+    return $obj if $ref eq 'JSON::XS::Boolean';
+       my $newobj;
+
+    if(UNIVERSAL::isa($obj, 'HASH')) {
+        $newobj = {};
+        $newobj->{$_} = $class->perl2JSONObject($obj->{$_}) for (keys %$obj);
+    } elsif(UNIVERSAL::isa($obj, 'ARRAY')) {
+        $newobj = [];
+        $newobj->[$_] = $class->perl2JSONObject($obj->[$_]) for(0..scalar(@$obj) - 1);
+    }
+
+    if($ref ne 'HASH' and $ref ne 'ARRAY') {
+               $ref = $class->lookup_hint($ref) || $ref;
+               $newobj = {$JSON_CLASS_KEY => $ref, $JSON_PAYLOAD_KEY => $newobj};
+    }
+
+       return $newobj; 
+}
+
+
+sub rawJSON2perl {
+       my $class = shift;
+    my $json = shift;
+    return undef unless defined $json and $json !~ /^\s*$/o;
+    return $parser->decode($json);
+}
+
+sub rawPerl2JSON {
+       my ($class, $perl) = @_;
+    return $parser->encode($perl);
+}
+
+1;
diff --git a/src/perl/lib/OpenSRF/Utils/LogServer.pm b/src/perl/lib/OpenSRF/Utils/LogServer.pm
new file mode 100644 (file)
index 0000000..c27f512
--- /dev/null
@@ -0,0